perm filename LIBPAS.BKP[PAS,SYS]1 blob
sn#379464 filedate 1978-09-07 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00036 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00005 00002 (*$E+,T-,S1200
C00006 00003 PROGRAM CCL, OPTION, GETOPTION, GETFILENAME, GETPARAMETER
C00009 00004 TYPE
C00012 00005 (** ENTER ENTER←SWITCH **)
C00014 00006 (** OPTION FIND←SWITCH GETOPTION PICTURE **)
C00018 00007 (** GETFILENAME RE←INITIALIZE INITIALIZE READCHAR READOCTAL READDECIMAL SETSTATUS READSWITCH OPERAND NEXTCH ASSIGNFILENAMEOREXTENSION **)
C00029 00008 (** GETPARAMETER INITIALIZE **)
C00036 00009 PROGRAM DDT, DEBUG
C00046 00010 VAR
C00050 00011 (** DEBUG SYSTEM←ERROR ERROR NEWLINE LENGTH **)
C00053 00012 (** INSYMBOL NEXTCH **)
C00062 00013 (** ACRPOINT TESTGLOBALBASIS IDTREE FIRSTBASIS SUCCBASIS SEARCHSECTION SEARCHID **)
C00067 00014 (** GETBOUNDS COMPTYPES **)
C00072 00015 (** NEXTBYTE PUTNEXTBYTE **)
C00075 00016 (** LOAD GETFIELD SELECTOR **)
C00083 00017 (** VARIABLE **)
C00085 00018 (** EXPRESSION SIMPLEEXPRESSION TERM FACTOR **)
C00090 00019 (** SHIFTED←OUT WRITESCALAR PUTSIXBIT **)
C00095 00020 (** WRITESTRUCTURE WRITEFIELDLIST **)
C00110 00021 (** ASSIGNMENT **)
C00112 00022 (** STOPSEARCH PAGEVALUE LINEVALUE BREAKPOINT GETLINPAG **)
C00120 00023 (** LINEINTERVAL STOPMESSAGE TRACEOUT ONE←VAR←OUT **)
C00124 00024 (** SECTION←OUT OUT **)
C00129 00025 (** STACK←OUT HEAP←OUT **)
C00133 00026 (** WRITE←PROGRAM←NAME HEADER BACK←TO←TTY CORRECT←ADDR RIGHT←ADDR **)
C00137 00027 (** INIT DEBUG←INTERACTIVE **)
C00144 00028 (** DEBUG←BATCH **)
C00147 00029 PROGRAM STATUS, GETSTATUS
C00149 00030 (** GETSTATUS **)
C00150 00031 PROGRAM READ, READSCALAR, READIRANGE,
C00153 00032 (** STOP ERROR NEXTCH SKIP READIRANGE READCRANGE READRRANGE **)
C00158 00033 (** READSCALAR READIDENTIFIER READSET **)
C00165 00034 (** READISET READCSET READDSET **)
C00167 00035 PROGRAM WRITE, WRTSCALAR, WRTISET, WRTCSET, WRTDSET
C00169 00036 (** WRTSCALAR WRTSET WRTISET WRTCSET WRTDSET **)
C00174 ENDMK
C⊗;
(*$E+,T-,S1200
PASCAL RUNTIME PROGRAM LIBRARY (24-AUG-76,KISICKI)
DICTIONARY:
PAGE1 : DICTIONARY
PAGE2 : CCL
PAGE3 : DDT
PAGE4 : STATUS
PAGE5 : READ
PAGE6 : WRITE
PAGE7 : UNDEFINED
*)
PROGRAM CCL, OPTION, GETOPTION, GETFILENAME, GETPARAMETER;
(******************************************************************************************
*
* (C) COPYRIGHT H.-H. NAGEL
* INSTITUT FUER INFORMATIK
* DER UNIVERSITAET HAMBURG
* SCHLUETERSTRASSE 70
* 2000 HAMBURG 13
* GERMANY
* 1976
*
*
* PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
*
* DECSYSTEM-10 CONCISE COMMAND LANGUAGE INTERFACE
*
* PASCAL RUNTIME-SUPPORTS: GETPARAMETER
*
* PRE-DECLARED FUNCTIONS: OPTION
*
* PRE-DECLARED PROCEDURES: GETOPTION,
* GETFILENAME
*
* DEFINITIONS:
*
* <FILE SPECIFICATION> ::= <EMPTY> OR <FILENAME> OR
* <DEVICE>:<FILENAME>.<EXTENSION>[<PROJECT>,<PROGRAMMER>]<<PROTECTION>>
* (<SWITCH>/.../<SWITCH>)
* /<SWITCH>.../<SWITCH>
*
* <PROGRAMNAME>, <DEVICE>, <FILENAME>, <EXTENSION> ::= <IDENTIFIER>
* <PROJECT>, <PROGRAMMER>, <PROTECTION> ::= <UNSIGNED OCTAL NUMBER>
* <SWITCH> ::= <IDENTIFIER> OR <IDENTIFIER>:<VALUE>
* <VALUE> ::= <UNSIGNED DECIMAL NUMBER>
*
****************************************************************************************)
TYPE
ANYFILE = FILE OF INTEGER;
PACK9 = PACKED ARRAY[1..9] OF CHAR;
PACK6 = PACKED ARRAY[1..6] OF CHAR;
PACK5 = PACKED ARRAY[1..5] OF CHAR;
SOURCE←FORM = (TEMPFILE,COMMANDFILE,TELETYPEOUTPUT,TELETYPEINPUT,TELETYPE);
DELIMITER = (BLANK,LPARENT,RPARENT,COMMA,POINT,SLASH,LESS,EQUAL,GREATER,RBRACK,LBRACK,COLON,EXCLAMATION,UNKNOWN);
SWP = ↑SWITCH←DESCRIPTOR;
SWITCH←DESCRIPTOR = PACKED RECORD
NAME: ALFA;
LEFT, RIGHT: SWP;
VALUE: INTEGER
END;
VAR
CALLCNT, PROT←OLD, UFD←OLD: INTEGER;
TMP←FILENAME, COM←FILENAME, FILE←OLD: PACK9;
SOURCE: SOURCE←FORM;
END←OF←FILENAME, DEFAULTED, ERROR, USERCALL: BOOLEAN;
LASTCH: CHAR;
DEVICE←OLD: PACK6;
CURRENT←SWITCH, NEW←SWITCH, SWITCH←TREE: SWP;
DELIMITER1: ARRAY[' '..'/'] OF DELIMITER;
DELIMITER2: ARRAY[':'..'>'] OF DELIMITER;
DELIMITER3: ARRAY['['..']'] OF DELIMITER;
INITPROCEDURE;
BEGIN
SOURCE := TEMPFILE; CALLCNT := 0; USERCALL := TRUE; ERROR := FALSE;
DEFAULTED := TRUE; LASTCH := ' ';
COM←FILENAME := ' CMD';
TMP←FILENAME := ' TMP';
SWITCH←TREE := NIL; CURRENT←SWITCH := NIL;
DELIMITER1[' '] := BLANK; DELIMITER1['!'] := EXCLAMATION;
DELIMITER1['('] := LPARENT; DELIMITER1[')'] := RPARENT;
DELIMITER1[','] := COMMA; DELIMITER1['.'] := POINT;
DELIMITER1['/'] := SLASH;
DELIMITER2[':'] := COLON; DELIMITER2['<'] := LESS;
DELIMITER2['='] := EQUAL; DELIMITER2['>'] := GREATER;
DELIMITER3['['] := LBRACK; DELIMITER3[']'] := RBRACK;
END;
(** ENTER ENTER←SWITCH **)
PROCEDURE ENTER(FNAME: ALFA; FVALUE: INTEGER);
PROCEDURE ENTER←SWITCH(FTREE: SWP);
BEGIN
WITH FTREE↑ DO
IF NEW←SWITCH↑.NAME <> NAME
THEN
IF NEW←SWITCH↑.NAME < NAME
THEN
IF LEFT = NIL
THEN LEFT := NEW←SWITCH
ELSE ENTER←SWITCH(LEFT)
ELSE
IF RIGHT = NIL
THEN RIGHT := NEW←SWITCH
ELSE ENTER←SWITCH(RIGHT)
END (* ENTER←SWITCH *);
BEGIN (* ENTER *)
NEW(NEW←SWITCH);
WITH NEW←SWITCH↑ DO
BEGIN
NAME := FNAME; VALUE := FVALUE;
LEFT := NIL ; RIGHT := NIL
END;
IF SWITCH←TREE = NIL
THEN SWITCH←TREE := NEW←SWITCH
ELSE ENTER←SWITCH(SWITCH←TREE)
END (* ENTER *);
(** OPTION FIND←SWITCH GETOPTION PICTURE **)
(**********************************************************************
*
* FUNCTION OPTION
*
* - TEST IF <SWITCH> "SWITCHNAME" HAS BEEN
* SPECIFIED IN THE DECSYSTEM-10 COMMAND-STRING
* INTERPRETED BY PREVIOUS GETPARAMETER-/GETFILENAME-CALLS.
*
* OPTION IS A PRE-DECLARED FUNCTION AND AVAILABLE TO EVERY
* PASCAL USER.
*
**********************************************************************)
FUNCTION OPTION(SWITCHNAME: ALFA): BOOLEAN;
FUNCTION FIND←SWITCH( FTREE: SWP): BOOLEAN;
BEGIN
IF FTREE <> NIL
THEN
WITH FTREE↑ DO
IF SWITCHNAME = NAME
THEN
BEGIN
FIND←SWITCH := TRUE; CURRENT←SWITCH := FTREE
END
ELSE
IF SWITCHNAME < NAME
THEN
FIND←SWITCH := FIND←SWITCH(LEFT)
ELSE
FIND←SWITCH := FIND←SWITCH(RIGHT)
ELSE FIND←SWITCH := FALSE
END (* FIND←SWITCH *);
BEGIN (*OPTION*)
IF SWITCH←TREE = NIL
THEN
OPTION := FALSE
ELSE
OPTION := FIND←SWITCH(SWITCH←TREE)
END (*OPTION*);
(**********************************************************************
*
* PROCEDURE GETOPTION
*
* - ASSIGN <VALUE> OF "SWITCHNAME" TO "SWITCHVALUE".
*
* GETOPTION IS A PRE-DECLARED PROCEDURE AND AVAILABLE TO EVERY
* PASCAL USER.
*
**********************************************************************)
PROCEDURE GETOPTION(SWITCHNAME: ALFA; VAR SWITCHVALUE: INTEGER);
BEGIN
IF OPTION(SWITCHNAME)
THEN
WITH CURRENT←SWITCH↑ DO
SWITCHVALUE := VALUE
ELSE
SWITCHVALUE := 0
END (* GETOPTION *);
FUNCTION PICTURE(FCH: CHAR): DELIMITER;
BEGIN
IF FCH IN [' ','!','(',')',',','.','/',':','<','=','>','[',']']
THEN
IF FCH <= '/'
THEN PICTURE := DELIMITER1[FCH]
ELSE
IF FCH <= '>'
THEN PICTURE := DELIMITER2[FCH]
ELSE PICTURE := DELIMITER3[FCH]
ELSE PICTURE := UNKNOWN;
END (* PICTURE *);
(** GETFILENAME RE←INITIALIZE INITIALIZE READCHAR READOCTAL READDECIMAL SETSTATUS READSWITCH OPERAND NEXTCH ASSIGNFILENAMEOREXTENSION **)
(**********************************************************************
*
* PROCEDURE GETFILENAME
*
* - READ DECSYSTEM-10 <FILE SPECIFICATION> FROM
* "SOURCEFILE".
*
* GETFILENAME IS A PRE-DECLARED PROCEDURE
* AND AVAILABLE TO EVERY PASCAL USER.
*
**********************************************************************)
PROCEDURE GETFILENAME(VAR SOURCEFILE: TEXT;
VAR FILENAME: PACK9;
VAR PROTECTION,UFD: INTEGER;
VAR DEVICE: PACK6;
FILEVARIABLE: ALFA);
VAR
BUFFER: ALFA;
I, J, K, IMAX, OCVAL, SOURCE←PROT, SOURCE←PPN: INTEGER;
SOURCE←FIL: PACKED ARRAY[1..9] OF CHAR;
SOURCE←DEV: PACKED ARRAY[1..6] OF CHAR;
CH,STATUS: CHAR;
NEW←STATUS: BOOLEAN;
PROCEDURE RE←INITIALIZE;
BEGIN
I := 0; BUFFER := ' '; OCVAL := 0;
NEW←STATUS := FALSE;
END (* RE←INITIALIZE *);
PROCEDURE INITIALIZE;
BEGIN
FILENAME := ' '; DEVICE := 'DSK '; STATUS := ' '; IMAX := 6;
CH := ' '; UFD := 0; PROTECTION := 0; ERROR := FALSE; END←OF←FILENAME := FALSE;
RE←INITIALIZE; DEFAULTED := TRUE
END (* INITIALIZE *);
PROCEDURE READCHAR;
BEGIN
I := I + 1;
IF I > IMAX
THEN ERROR := TRUE
ELSE BUFFER[I] := CH
END (*READCHAR*) ;
PROCEDURE READOCTAL;
BEGIN
IF CH IN ['0'..'7']
THEN
BEGIN
OCVAL := OCVAL * 10B + ORD(CH) - ORD('0')
END
ELSE ERROR := TRUE
END (*READOCTAL*) ;
PROCEDURE READDECIMAL;
BEGIN
IF CH IN ['0'..'9']
THEN
BEGIN
OCVAL := OCVAL * 10 + ORD(CH) - ORD('0')
END
ELSE ERROR := TRUE
END (*READDECIMAL*) ;
PROCEDURE SETSTATUS;
BEGIN
IF CH <> ' '
THEN
BEGIN
CASE PICTURE(CH) OF
COLON :
ERROR := STATUS <> ' ';
POINT :
ERROR := NOT (STATUS IN [' ',':']);
LBRACK :
ERROR := NOT (STATUS IN [' ',':','.']);
LESS :
ERROR := NOT (STATUS IN [' ',':','.',']']);
COMMA :
ERROR := STATUS <> '[';
RBRACK :
ERROR := STATUS <> ',';
GREATER :
ERROR := STATUS <> '<';
SLASH :
ERROR := NOT (STATUS IN [' ',':','.',']','>',')']);
LPARENT :
ERROR := NOT (STATUS IN [' ',':','.',']','>']);
RPARENT :
ERROR := STATUS <> '(';
OTHERS :
ERROR := TRUE
END;
IF NOT ERROR
THEN
BEGIN
NEW←STATUS := TRUE; STATUS := CH
END
END
END (*SETSTATUS*) ;
PROCEDURE READSWITCH;
VAR
READ←VALUE, END←OF←SWITCH: BOOLEAN;
BEGIN
IF NOT EOLN(SOURCEFILE)
THEN
BEGIN
REPEAT
IMAX := ALFALENGTH;
RE←INITIALIZE;
READ←VALUE := FALSE;
END←OF←SWITCH := FALSE;
LOOP
IF EOLN(SOURCEFILE)
THEN
BEGIN
END←OF←SWITCH := TRUE; CH := ' '
END
ELSE READ(SOURCEFILE,CH);
LASTCH := CH
EXIT IF NOT (CH IN ['0'..'9',':','A'..'Z',' ']) OR END←OF←SWITCH;
IF CH <> ' '
THEN
IF READ←VALUE
THEN READDECIMAL
ELSE
IF CH = ':'
THEN READ←VALUE := TRUE
ELSE READCHAR
END;
IF I > 0
THEN ENTER(BUFFER,OCVAL)
UNTIL NOT (CH IN ['/','!',',']) OR ((CH = ',') AND (STATUS <> '(')) OR END←OF←SWITCH;
IF CH IN [',','=']
THEN
BEGIN
END←OF←FILENAME := TRUE; CH := ' '
END;
SETSTATUS
END
END (* READSWITCH *);
PROCEDURE OPERAND;
PROCEDURE NEXTCH;
BEGIN
IF EOLN(SOURCEFILE)
THEN
BEGIN
END←OF←FILENAME := TRUE; CH := ' '
END
ELSE READ(SOURCEFILE,CH);
LASTCH := CH;
IF END←OF←FILENAME OR ((CH=',') AND (STATUS<>'[')) OR (CH='=')
THEN
BEGIN
END←OF←FILENAME := TRUE;
CASE PICTURE(STATUS) OF
BLANK:
CH := '.';
COLON:
CH := '.';
POINT:
CH := '[';
RPARENT,
SLASH,
GREATER,
RBRACK:
BEGIN
CH := ' '; STATUS := ' '
END;
OTHERS:
BEGIN
ERROR := TRUE; CH := ' '
END
END
END
END (*NEXTCH*) ;
BEGIN
(*OPERAND*)
REPEAT
NEXTCH;
IF CH IN ['A'..'Z','0'..'9']
THEN
IF STATUS IN ['[',',','<']
THEN READOCTAL
ELSE READCHAR
ELSE SETSTATUS
UNTIL NEW←STATUS OR ERROR OR END←OF←FILENAME
END (*OPERAND*) ;
PROCEDURE ASSIGNFILENAMEOREXTENSION;
BEGIN
IF I > 0
THEN
IF (FILENAME[1] = ' ') OR ((FILENAME[7] = ' ') AND (IMAX = 3))
THEN
BEGIN
IF IMAX = 3
THEN K := 6
ELSE K := 0;
FOR J := 1 TO IMAX DO FILENAME[K+J] := BUFFER[J];
END
END;
BEGIN
(*GETFILENAME*)
IF USERCALL
THEN
BEGIN
GETSTATUS(SOURCEFILE, SOURCE←FIL, SOURCE←PROT, SOURCE←PPN, SOURCE←DEV);
IF SOURCE←DEV = 'TTY '
THEN
BEGIN
WRITE(TTY,CR,LF,FILEVARIABLE,'= ');
BREAK(TTY);
READLN(SOURCEFILE)
END
END;
INITIALIZE;
IF NOT EOF(SOURCEFILE)
THEN
IF NOT EOLN(SOURCEFILE)
THEN
REPEAT
OPERAND;
IF NOT ERROR
THEN
BEGIN
CASE PICTURE(STATUS) OF
COLON:
IF I > 0
THEN BEGIN
DEVICE := ' ' ;
FOR J := 1 TO I DO DEVICE[J] := BUFFER[J];
END ;
POINT:
BEGIN
ASSIGNFILENAMEOREXTENSION; IMAX := 3
END;
LESS,
LBRACK:
ASSIGNFILENAMEOREXTENSION;
LPARENT,
SLASH:
BEGIN
ASSIGNFILENAMEOREXTENSION; READSWITCH
END;
COMMA :
UFD := OCVAL * 1000000B;
RBRACK :
UFD := UFD + OCVAL;
GREATER :
PROTECTION := OCVAL
END;
RE←INITIALIZE; DEFAULTED := FALSE
END
UNTIL ERROR OR END←OF←FILENAME;
DEFAULTED := FILENAME[1] = ' ';
IF NOT (USERCALL OR DEFAULTED)
THEN
IF NOT ERROR AND EOLN(SOURCEFILE) AND (PRED(SOURCE) <= COMMANDFILE) AND NOT EOF(SOURCEFILE)
THEN
BEGIN
READLN(SOURCEFILE); STATUS := ' '; CH := ' '; READSWITCH
END;
IF ERROR AND USERCALL
THEN
BEGIN
WRITELN(TTY,'%? SYNTAX ERROR: REENTER'); BREAK(TTY);
GETFILENAME(SOURCEFILE,FILENAME,PROTECTION,UFD,DEVICE,FILEVARIABLE)
END
ELSE USERCALL := TRUE
END (*GETFILENAME*);
(** GETPARAMETER INITIALIZE **)
(**********************************************************************
*
* PROCEDURE GETPARAMETER
*
* - READ A DECSYSTEM-10 <FILE SPECIFICATION> FROM EITHER
*
* * A TEMPCORE-FILE NAMED <1ST 3 CHARS. OF PROGRAMNAME>.TMP,
* CREATED BY DECSYSTEM-10 COMPIL-CLASS COMMANDS OR USER, OR
*
* * A COMMAND-FILE NAMED <1ST 6 CHARS. OF PROGRAMNAME>.CMD,
* CREATED BY USER, OR
*
* * TTY
*
* ALL FILES HAVE TO BE "TEXT"-FILES.
*
* TEMPCORE-FILES CAN BE ACCESSED AND CREATED AUTOMATICALLY
* BY PASCAL PROGRAMS IF THE FILENAME IS SPECIFIED AS
* 'XXX TMP' AND DEVICE IS 'DSK ', WHERE XXX ARE
* THE 1ST 3 CHARACTERS OF THE <PROGRAMNAME>. IF THE TEMPCORE-FILE
* CANNOT BE FOUND/CREATED THE DISK-FILE 'NNNXXXTMP' IS
* SEARCHED/CREATED, WHERE NNN IS THE JOB-NUMBER.
*
* - GETPARAMETER IS PART OF THE PASREL RUNTIME-SUPPORT.
* A CALL OF GETPARAMETER IS GENERATED BY THE PASREL COMPILER
* FOR EACH PARAMETER SPECIFIED IN THE <PROGRAM HEADING>.
*
* THE INPUT FORMAT IS FOR
*
* * TEMPCORE- AND COMMAND-FILES:
*
* <FILE SPECIFICATION>,...,<FILE SPECIFICATION><CR><LF>
* <SWITCH>!...<SWITCH>!<CR><LF>
*
* THE SECOND LINE (USED BY COMPIL-CLASS COMMANDS) IS OPTIONAL
*
* * TTY:
*
* <FILE SPECIFICATION><CR><LF>
*
***********************************************************************)
PROCEDURE GETPARAMETER(VAR CURRENTFILE: ANYFILE;
VAR FILEIDENT,PROGRAMNAME:ALFA;
INPUTFILE:BOOLEAN);
VAR
PROTECTION, UFD, I: INTEGER;
FILENAME: PACK9;
DEVICE: PACK6;
PROCEDURE INITIALIZE;
BEGIN
IF SOURCE <> TELETYPE
THEN
BEGIN
CASE SOURCE OF
TEMPFILE:
BEGIN
FOR I := 1 TO 6 DO COM←FILENAME[I] := PROGRAMNAME[I];
FOR I := 1 TO 3 DO TMP←FILENAME[I] := PROGRAMNAME[I];
RESET(TTY,TMP←FILENAME,0,0,'DSK ')
END;
COMMANDFILE:
RESET(TTY,COM←FILENAME);
TELETYPEOUTPUT:
REWRITE(TTY,'TTYOUTPUT');
TELETYPEINPUT:
RESET(TTY,'TTY ',0,0,'TTY ')
END;
SOURCE := SUCC(SOURCE);
IF EOF(TTY) AND NOT (SOURCE IN [TELETYPEINPUT,TELETYPE])
THEN INITIALIZE;
END
END (* INITIALIZE *);
BEGIN (*GETPARAMETER*)
IF CALLCNT = 0
THEN
INITIALIZE;
CALLCNT := CALLCNT + 1;
GETSTATUS(CURRENTFILE,FILE←OLD,PROT←OLD,UFD←OLD,DEVICE←OLD);
LOOP
IF SOURCE IN [TELETYPE,TELETYPEINPUT]
THEN
BEGIN
WRITE(TTY,FILEIDENT,'= ');BREAK(TTY);
IF SOURCE = TELETYPEINPUT
THEN INITIALIZE
ELSE READLN(TTY)
END;
USERCALL := FALSE;
GETFILENAME(TTY,FILENAME,PROTECTION,UFD,DEVICE,' ');
IF DEVICE = 'LPT '
THEN ENTER('LPT ',0) ;
ERROR := (INPUTFILE AND NOT DEFAULTED AND (DEVICE = 'LPT ')) OR ERROR;
IF NOT ERROR
THEN
IF DEFAULTED
THEN
IF INPUTFILE
THEN
RESET(CURRENTFILE,FILE←OLD,PROT←OLD,UFD←OLD,DEVICE←OLD)
ELSE
REWRITE(CURRENTFILE,FILE←OLD,PROT←OLD,UFD←OLD,DEVICE←OLD)
ELSE
IF INPUTFILE
THEN
RESET(CURRENTFILE,FILENAME,PROTECTION,UFD,DEVICE)
ELSE
REWRITE(CURRENTFILE,FILENAME,PROTECTION,UFD,DEVICE)
EXIT IF ( (NOT EOF(CURRENTFILE) AND INPUTFILE) OR (EOF(CURRENTFILE) AND NOT INPUTFILE) ) AND NOT ERROR;
IF SOURCE <> TELETYPE
THEN
BEGIN
SOURCE := TELETYPEOUTPUT; INITIALIZE
END;
IF ERROR
THEN WRITELN(TTY,'%? SYNTAX ERROR: REENTER')
ELSE
BEGIN
WRITE(TTY,'%? NO ACCESS TO ');
IF FILENAME = ' '
THEN WRITE(TTY,FILEIDENT:6,'.',FILEIDENT[7],FILEIDENT[8],FILEIDENT[9])
ELSE WRITE(TTY,FILENAME:6,'.',FILENAME[7],FILENAME[8],FILENAME[9]);
WRITELN(TTY,' OR NOT FOUND: REENTER')
END;
BREAK(TTY)
END
END (*GETPARAMETER*) ;
BEGIN
END.
PROGRAM DDT, DEBUG;
(************************************************************
* *
* *
* PASCAL-DDT PROGRAM *
* ****************** *
* *
* *
* AUTHOR: PETER PUTFARKEN *
* *
* POST - MORTEM - DUMP BY *
* B. NEBEL AND B. PRETSCHNER (APR 76) *
* *
* INSTITUT FUER INFORMATIK *
* SCHLUETERSTRASSE 70 *
* D-2000 HAMBURG 13 *
* GERMANY *
* *
* *
***********************************************************)
CONST
VERSION = 'DEBUG(VERSION FROM 25-AUG-76)';
STOPMAX = 20;
BUFFMAX = 120;
BITMAX = 36;
BASEMAX = 71;
STRGLGTH = 120;
OFFSET = 40B;
MAXTABS = 4;
TYPE
ACRANGE = 0..15; BIT = 0..1;
BITRANGE = 0..BITMAX;
ADDRRANGE = 0..777777B;
LINEELEM = PACKED RECORD
CASE INTEGER OF
1: (CODE:0..677B; AC:ACRANGE; IB:BIT; INXR:ACRANGE; ADP:↑LINEELEM);
2: (CONSTANT1: INTEGER;
DB2: ADDRRANGE; ABSLINE: ADDRRANGE)
END;
PAGEELEM = PACKED RECORD
INSTR: 0..677B; AC: ACRANGE; DUMMYBIT: BIT; INXREG: ACRANGE; PAGPTR: ↑PAGEELEM;
LASTLINE: ADDRRANGE; LASTSTOP: ↑LINEELEM
END;
STRINGTYP = PACKED ARRAY [1:STRGLGTH] OF CHAR;
CSTCLASS = (INT,REEL,PSET,STRD,STRG);
SIXBIT=PACKED ARRAY[1..6] OF 0..77B;
CSP = ↑CONSTNT;
CONSTNT = RECORD
SELFCSP: CSP; NOCODE: BOOLEAN;
CASE CCLASS: CSTCLASS OF
INT : (INTVAL: INTEGER; INTVAL1: INTEGER)
END;
VALU = RECORD
CASE INTEGER OF
1: (IVAL: INTEGER);
2: (RVAL: REAL);
3: (BVAL: BOOLEAN);
4: (VALP: CSP)
END;
BITS5 = 0..37B; BITS6 = 0..77B; BITS7 = 0..177B;
BITS17 = 0..377777B; BITS18 = 0..777777B;
STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES,TAGFWITHID,TAGFWITHOUTID,VARIANT);
FORMSET=SET OF STRUCTFORM;
DECLKIND = (STANDARD,DECLARED);
STP = ↑STRUCTURE; CTP = ↑IDENTIFIER;
STRUCTURE = PACKED RECORD
SELFSTP: STP; SIZE: ADDRRANGE;
NOCODE: BOOLEAN;
BITSIZE: BITRANGE;
CASE FORM: STRUCTFORM OF
SCALAR: (CASE SCALKIND: DECLKIND OF
DECLARED: (DB0:BITS6; FCONST: CTP));
SUBRANGE: (DB1:BITS7; RANGETYPE: STP; MINV,MAXV: VALU);
POINTER: (DB2:BITS7; ELTYPE: STP);
POWER: (DB3:BITS7; ELSET: STP);
ARRAYS: (ARRAYPF: BOOLEAN; DB4:BITS6; ARRAYBPADDR: ADDRRANGE;
AELTYPE,INXTYPE: STP);
RECORDS: (RECORDPF:BOOLEAN; DB5:BITS6;
FSTFLD: CTP; RECVAR: STP);
FILES: (DB6: BITS6; FILEPF: BOOLEAN; FILTYPE: STP);
TAGFWITHID,
TAGFWITHOUTID: (DB7:BITS7; FSTVAR: STP;
CASE BOOLEAN OF
TRUE : (TAGFIELDP: CTP);
FALSE: (TAGFIELDTYPE: STP));
VARIANT: (DB9: BITS7; NXTVAR,SUBVAR: STP; FIRSTFIELD: CTP; VARVAL: VALU)
END;
(* ALFA = PACKED ARRAY[1..ALFALENG] OF CHAR; *)
LEVRANGE = 0..10;
IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC,LABELS);
IDKIND = (ACTUAL,FORMAL);
PACKKIND = (NOTPACK,PACKK,HWORDR,HWORDL);
BPOINTER = PACKED RECORD
SBITS,PBITS: BITRANGE;
IBIT,DUMMYBIT: BIT;
IREG: ACRANGE;
RELADDR: ADDRRANGE
END;
IDENTIFIER = PACKED RECORD
NAME: ALFA; LLINK, RLINK: CTP;
IDTYPE: STP; NEXT: CTP;
SELFCTP: CTP; NOCODE: BOOLEAN;
CASE KLASS: IDCLASS OF
KONST: (VALUES: VALU);
VARS: (VKIND: IDKIND; VLEV: LEVRANGE;
CHANNEL: ACRANGE; VDUMMY1: 0..37B; VDUMMY2:0..777777B; VADDR: ADDRRANGE);
FIELD: (CASE PACKF: PACKKIND OF
NOTPACK,
HWORDL,
HWORDR: (FDUMMY: 0..7777B; FLDADDR: ADDRRANGE);
PACKK: (PDUMMY: 0..7777B; FLDBYTE: BPOINTER));
PROC,
FUNC: (CASE PFDECKIND: DECLKIND OF
STANDARD: (KEY: 1..44);
DECLARED: (PFLEV: LEVRANGE; PFADDR: ADDRRANGE))
END;
SYMBOL= (STOPSY, TRACESY, ENDSY, NOTSY, EOLSY, IDENT, INTCONST, STRINGCONST,
CHARCONST, REALCONST, LBRACK, RBRACK, COMMA, PERIOD, ARROW, PLUS, MINUS, MUL,
SLASHSY, BECOMES, EQSY, LPARENT, RPARENT, OTHERSY, STACKDUMPSY, HEAPDUMPSY);
ASCII←MNEMONICS = (NUL,SOH,STX,ETX,EOT,ENQ,ACK,BEL,
BS,HT,LF,VT,FF,CR,SO,SI,
DLE,DC1,DC2,DC3,DC4,NAK,SYN,ETB,
CAN,EM,SUB,ESC,FS,GS,RS,US,DEL);
ACR = ↑ AKTIVIERUNGSRECORD;
AKTIVIERUNGSRECORD = ARRAY [0..0] OF INTEGER;
ATTRKIND = (CST,VARBL,EXPR);
ATTR = RECORD
TYPTR: STP;
CASE KIND: ATTRKIND OF
CST,
EXPR: (CVAL: VALU);
VARBL:(PACKFG: BOOLEAN;
GADDR: ADDRRANGE;
GBITCOUNT: BITRANGE;
MAXADDR:ADDRRANGE)
END;
LEFTORRIGHT=(LEFT,RIGHT);
DEBUGENTRY = RECORD
LASTPAGEELEM: PAGEELEM;
GLOBALIDTREE: CTP;
STANDARDIDTREE: CTP;
INTPTR: STP;
REALPTR: STP;
BOOLPTR: STP;
CHARPTR: STP
END;
STATUSKIND = (INITK, STOPK, DDTK, RUNTMERRK, HALTK);
DEBUGSTATUS = PACKED RECORD
DD: 0:77777B;
KIND: STATUSKIND;
RETURNADDR: ADDRRANGE
END;
DYNENTRY = PACKED RECORD
DUMM1: BITS18; (* LH 140B *)
REGISTRS: ACR; (* RH 140B *)
STOPPY: INTEGER; (* 141B *)
DUMM2: BITS18; (* LH 142B *)
ENTRYPTR: ↑DEBUGENTRY; (* RH 142B *)
DUMM3: BITS17;
INTERACTIVE: BOOLEAN; (* LH 143B *)
STACKBOTTOM: ACR; (* RH 143B *)
STATUS: DEBUGSTATUS; (* 144B *)
TIME←LIMIT: INTEGER; (* 145B USED ONLY BY BATCH JOBS *)
PUSHJ←INDEB: INTEGER; (* 146B *)
DUMMI146: ADDRRANGE; (* 147B LH *)
NAME←PNT←PNT: ACR (* 147B RH POINTER OF POINTER OF PROGRAM-NAME *)
END;
VAR
DUMP, TABS: BOOLEAN;
TABULATOR: ARRAY[BOOLEAN,1..MAXTABS] OF INTEGER;
FILE←NAME: PACKED ARRAY[1..9] OF CHAR;
ASCII←CHANGE: RECORD
CASE INTEGER OF
1: (IVAL: INTEGER);
2: (MNEMO: ASCII←MNEMONICS)
END;
DAY, DAY←TIME: ALFA;
DEVICE:PACKED ARRAY[1..6] OF CHAR;
CH: CHAR;
ID: ALFA;
VAL: VALU;
STRING: ↑STRINGTYP;
STRINGPTR, STRINGINDEX: STP;
LGTH: INTEGER;
CHCNT, LEFTSPACE: INTEGER;
SY: SYMBOL;
BUFFER: PACKED ARRAY[1:BUFFMAX] OF CHAR;
BUFFLNG: 0:BUFFMAX;
GPAGE: INTEGER; (*CURRENT PAGENUMBER*)
STOPTABLE: ARRAY[1..STOPMAX] OF PACKED RECORD
THISLINE: INTEGER;
PAGE: ADDRRANGE;
THISADDR: ↑LINEELEM;
ORIGINALCONT: INTEGER
END;
STOPNR: 0..STOPMAX;
ENTRY1: DEBUGENTRY;
ENTRY2: DYNENTRY;
POINTERCV: PACKED RECORD
CASE INTEGER OF
0:(ADDR: ADDRRANGE);
1:(ENTPTR2: ↑DYNENTRY);
2:(STRINGPTR: ↑STRINGTYP);
3:(CTPTR: CTP);
4:(ALFAPNT:↑ALFA)
END;
HEAPCV:PACKED RECORD
CASE BOOLEAN OF
TRUE: (CIVAL:INTEGER);
FALSE: (CIDTYPE:STP;
CACR:ACR)
END;
MERKBASIS,BASIS, ACCUS, NULLPTR: ACR;
BYTECV: PACKED RECORD
CASE BOOLEAN OF
FALSE: (BITS: PACKED ARRAY[1..BITMAX] OF BIT );
TRUE : (INTCONST: INTEGER)
END;
LADDR: ADDRRANGE;
DIGITS, LETTERSDIGITSORLEFTARROW: SET OF CHAR;
NL: BOOLEAN;
GATTR: ATTR;
(******************************************************************************************************)
INITPROCEDURE;
BEGIN
DIGITS :=['0'..'9'];
LETTERSDIGITSORLEFTARROW:=['A'..'Z','0'..'9', '←'];
STRING := NIL;
TABULATOR[TRUE,1]:=35;
TABULATOR[TRUE,2]:=65;
TABULATOR[TRUE,3]:=95;
TABULATOR[TRUE,4]:=377777777777B;
TABULATOR[FALSE,1]:=0;
TABULATOR[FALSE,2]:=0;
TABULATOR[FALSE,3]:=35;
TABULATOR[FALSE,4]:=377777777777B;
TABS:=FALSE;
DUMP:=FALSE;
END;
(** DEBUG SYSTEM←ERROR ERROR NEWLINE LENGTH **)
PROCEDURE DEBUG;
PROCEDURE SYSTEM←ERROR( KIND : INTEGER );
BEGIN
WRITELN(TTY);
WRITELN(TTY,'%? DEBUG-SYSTEM ERROR: ',KIND:2);
HALT; (* JUMP TO "HALT.".
THERE WILL BE DECDECTED THAT
DEBUG IS LOADED. THEREFORE, JUMP TO
"ERRDB." AND EXIT *)
END;
PROCEDURE ERROR;
BEGIN
WRITE(TTY, '$', '↑ ':CHCNT+1 );
GATTR.TYPTR := NIL
END (*ERROR*);
PROCEDURE NEWLINE;
VAR
I:INTEGER;
BEGIN
I:=1;
IF TABS
THEN
WHILE (TABULATOR[DUMP,I] <= CHCNT) DO
I:=I+1;
IF (I = MAXTABS) OR NOT TABS
THEN
BEGIN
WRITELN(TTY);
WRITE(TTY,'$ ',' ':LEFTSPACE);
CHCNT:=LEFTSPACE;
END
ELSE
BEGIN
WRITE(TTY,' ':TABULATOR[DUMP,I]-CHCNT);
CHCNT:=TABULATOR[DUMP,I];
END (* ELSE *)
END (* NEWLINE *);
FUNCTION LENGTH(FVAL: INTEGER): INTEGER;
VAR
E, H: INTEGER;
BEGIN
IF FVAL < 0
THEN
BEGIN
E := 1; FVAL := -FVAL
END
ELSE E := 0;
H := 1;
IF FVAL >= 10000000000 (* 10**10 *)
THEN E := E + 11
ELSE
REPEAT
E := E + 1; H := H * 10
UNTIL (FVAL < H) ;
LENGTH := E
END (*LENGTH*);
(** INSYMBOL NEXTCH **)
PROCEDURE INSYMBOL;
CONST
MAX10 = 3817748707;
MAXEXP = 35;
VAR
IVAL,SCALE,EXP,I: INTEGER;
RVAL,R,FAC: REAL;
STRINGTOOLONG, SIGN: BOOLEAN;
PROCEDURE NEXTCH;
BEGIN
IF EOLN(TTY)
THEN CH:=' '
ELSE READ(TTY,CH);
CHCNT := CHCNT + 1
END (*NEXTCH*);
BEGIN
WHILE NOT EOLN(TTY) AND (CH=' ') DO NEXTCH;
CASE CH OF
' ':
SY := EOLSY;
'A','B','C','D','E','F','G','H','I','J','K','L','M',
'N','O','P','Q','R','S','T','U','V','W','X','Y',
'Z':
BEGIN
ID := ' '; I := 0;
REPEAT
IF I < ALFALENGTH
THEN
BEGIN
I := I + 1;
ID[I] := CH
END;
NEXTCH
UNTIL NOT ( CH IN LETTERSDIGITSORLEFTARROW );
SY := IDENT;
IF ID='NOT '
THEN SY:=NOTSY;
IF ID='STOP '
THEN SY:=STOPSY;
IF ID='TRACE '
THEN SY:=TRACESY;
IF ID='END '
THEN SY:=ENDSY;
IF ID='STACKDUMP '
THEN SY:=STACKDUMPSY;
IF ID='HEAPDUMP '
THEN SY:=HEAPDUMPSY;
IF SY IN [STOPSY,TRACESY,STACKDUMPSY,HEAPDUMPSY]
THEN
(* LOOK AHEAD, WHETHER ARGUMENT OR EOL FOLLOWS *)
BEGIN
WHILE NOT EOLN(TTY) AND (CH=' ') DO NEXTCH;
IF NOT (CH IN ['0'..'9','A'..'Z',' '] )
THEN SY:= IDENT
END
END;
'0','1','2','3','4','5','6','7','8',
'9':
BEGIN
IVAL := 0; SY := INTCONST;
REPEAT
IF IVAL <= MAX10
THEN IVAL := 10*IVAL + ORD(CH)-ORD('0')
ELSE
BEGIN
ERROR; WRITELN(TTY,'NUMBER TOO LARGE');
IVAL := 0
END;
NEXTCH
UNTIL NOT (CH IN DIGITS);
SCALE := 0;
IF CH = '.'
THEN
BEGIN
NEXTCH;
IF CH = '.'
THEN CH := ':'
ELSE
BEGIN
RVAL := IVAL; SY := REALCONST;
IF NOT (CH IN DIGITS)
THEN
BEGIN
ERROR; WRITELN(TTY,'DIGIT MUST FOLLOW')
END
ELSE
REPEAT
RVAL := 10.0*RVAL + (ORD(CH) - ORD('0'));
SCALE := SCALE - 1; NEXTCH
UNTIL NOT (CH IN DIGITS)
END
END;
IF CH = 'E'
THEN
BEGIN
IF SCALE = 0
THEN
BEGIN
RVAL := IVAL; SY := REALCONST
END;
NEXTCH;
SIGN := CH = '-' ;
IF (CH = '+') OR SIGN
THEN NEXTCH;
EXP := 0;
IF NOT (CH IN DIGITS)
THEN
BEGIN
ERROR; WRITELN(TTY,'DIGIT MUST FOLLOW')
END
ELSE
REPEAT
EXP := 10*EXP + ORD(CH) - ORD('0');
NEXTCH
UNTIL NOT (CH IN DIGITS);
IF SIGN
THEN SCALE := SCALE - EXP
ELSE SCALE := SCALE + EXP;
IF ABS(SCALE + LENGTH(IVAL) - 1) > MAXEXP
THEN
BEGIN
ERROR; WRITELN(TTY,'EXPONENT TOO LARGE');
SCALE := 0
END
END;
IF SCALE <> 0
THEN
BEGIN
R := 1.0; (*NOTE POSSIBLE OVERFLOW OR UNDERFLOW*)
IF SCALE < 0
THEN
BEGIN
FAC := 0.1; SCALE := -SCALE
END
ELSE FAC := 10.0;
REPEAT
IF ODD(SCALE)
THEN R := R*FAC;
FAC := SQR(FAC); SCALE := SCALE DIV 2
UNTIL SCALE = 0; (*NOW R = 10↑SCALE*)
RVAL := RVAL*R
END;
IF SY = INTCONST
THEN VAL.IVAL := IVAL
ELSE VAL.RVAL := RVAL
END;
':':
BEGIN
NEXTCH;
IF CH = '='
THEN
BEGIN
SY := BECOMES; NEXTCH
END
ELSE SY := OTHERSY
END;
'''':
BEGIN
LGTH := 0; STRINGTOOLONG := FALSE;
IF STRING = NIL
THEN
BEGIN
NEW(STRING); NEW(STRINGPTR,ARRAYS); NEW(STRINGINDEX,SUBRANGE);
WITH STRINGINDEX↑ DO
BEGIN
SIZE := 1; BITSIZE := 7;
RANGETYPE := ENTRY1.INTPTR; MINV.IVAL := 1
END;
WITH STRINGPTR↑ DO
BEGIN
BITSIZE := BITMAX; AELTYPE := ENTRY1.CHARPTR;
INXTYPE := STRINGINDEX; ARRAYPF := TRUE
END
END;
REPEAT
REPEAT
NEXTCH;
IF LGTH < STRGLGTH
THEN
BEGIN
LGTH := LGTH + 1; STRING↑[LGTH] := CH
END
ELSE STRINGTOOLONG := TRUE
UNTIL EOLN(TTY) OR (CH = '''');
IF STRINGTOOLONG
THEN
BEGIN
ERROR; WRITELN(TTY,'STRING CONSTANT IS TOO LONG')
END;
IF CH <> ''''
THEN
BEGIN
ERROR; WRITELN(TTY,'STRING CONSTANT CONTAINS "<CR><LF>"')
END
ELSE NEXTCH
UNTIL CH <> '''';
LGTH := LGTH - 1; (*NOW LGTH = NR OF CHARS IN STRING*)
IF LGTH = 1
THEN
BEGIN
SY := CHARCONST; VAL.IVAL := ORD(STRING↑[1])
END
ELSE
BEGIN
SY := STRINGCONST;
STRINGINDEX↑.MAXV.IVAL := LGTH;
STRINGPTR↑.SIZE := (LGTH + 4) DIV 5
END
END;
'=':
BEGIN
SY := EQSY; NEXTCH
END;
'/':
BEGIN
SY := SLASHSY; NEXTCH
END;
'[':
BEGIN
SY := LBRACK; NEXTCH
END;
']':
BEGIN
SY := RBRACK; NEXTCH
END;
'.':
BEGIN
SY := PERIOD; NEXTCH
END;
'↑':
BEGIN
SY := ARROW; NEXTCH
END;
',':
BEGIN
SY := COMMA; NEXTCH
END;
'+':
BEGIN
SY := PLUS; NEXTCH
END;
'*':
BEGIN
SY := MUL; NEXTCH
END;
'-':
BEGIN
SY := MINUS; NEXTCH
END;
'(':
BEGIN
SY := LPARENT; NEXTCH
END;
')':
BEGIN
SY := RPARENT; NEXTCH
END;
OTHERS:
SY := OTHERSY
END;
END (*INSYMBOL*);
(** ACRPOINT TESTGLOBALBASIS IDTREE FIRSTBASIS SUCCBASIS SEARCHSECTION SEARCHID **)
FUNCTION ACRPOINT(FINT:INTEGER;LLEFT:LEFTORRIGHT): ACR;
(*CONVERTS INTEGER TO ACR-POINTER*)
VAR
ACR←INT: PACKED RECORD
CASE BOOLEAN OF
FALSE:(LINT: INTEGER);
TRUE: (LACR,LACL: ACR)
END;
BEGIN
WITH ACR←INT DO
BEGIN
LINT := FINT;
IF LLEFT=LEFT
THEN ACRPOINT := LACL
ELSE ACRPOINT := LACR
END
END (*ACRPOINT*);
PROCEDURE TESTGLOBALBASIS;
BEGIN
IF BASIS = ENTRY2.STACKBOTTOM
THEN BASIS := NULLPTR
END (*TESTGLOBALBASIS*);
FUNCTION IDTREE: CTP;
(*POINTS TO THE IDTREE OF THE PROCEDURE, TO WHICH BASIS POINTS*)
VAR
I: INTEGER;
LACR: ACR;
BEGIN
IF BASIS = NULLPTR
THEN IDTREE := ENTRY1.GLOBALIDTREE
ELSE
BEGIN
LACR := ACRPOINT ( BASIS↑[0] - 1, RIGHT );
I := LACR↑[0];
REPEAT
I := I - 1;
LACR := ACRPOINT ( I, RIGHT)
UNTIL ORD(ACRPOINT(LACR↑[0],RIGHT)) <> 777777B (*HRR BASIS,-1(BASIS)*);
WITH POINTERCV DO
BEGIN
ADDR := LACR↑[0];
IDTREE := CTPTR
END
END
END (*IDTREE*);
PROCEDURE FIRSTBASIS;
(*GENERATES BASISPOINTER TO 'AKTIVIERUNGSRECORD' OF UNDERBREAKED PROCEDURE*)
BEGIN
BASIS := ACRPOINT ( ACCUS↑[0 +16B], RIGHT );
TESTGLOBALBASIS
END (*FIRSTBASIS*);
PROCEDURE SUCCBASIS(SIDE: LEFTORRIGHT);
(*GENERATES BASISPOINTER TO 'AKTIVIERUNGSR.'
OF STATIC/DYNAMIC HIGHER PROCEDURE)*)
(*SIDE: RIGHT FOR STATIC LINK
LEFT FOR DYNAMIC LINK*)
VAR
OLDBASIS:ACR;
BEGIN
OLDBASIS:=BASIS;
BASIS := ACRPOINT( BASIS↑[0-1], SIDE );
TESTGLOBALBASIS;
IF ORD(OLDBASIS) <= ORD(BASIS)
THEN
BEGIN
BASIS:=NULLPTR;
TABS:=FALSE; NEWLINE;
WRITE(TTY,'ERROR IN PROCEDURE-BACKTRACING'); NEWLINE;
END;
END (*SUCCBASIS*);
PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
LABEL
1;
BEGIN
WHILE FCP <> NIL DO WITH FCP↑ DO
BEGIN
IF NAME = ID
THEN GOTO 1;
IF NAME < ID
THEN FCP := RLINK
ELSE FCP := LLINK
END;
1:
FCP1 := FCP
END (*SEARCHSECTION*);
PROCEDURE SEARCHID(VAR FCP: CTP);
LABEL
1;
VAR
LCP: CTP;
BEGIN
FIRSTBASIS;
LOOP
SEARCHSECTION( IDTREE, LCP );
IF LCP <> NIL
THEN GOTO 1
EXIT IF BASIS = NULLPTR;
SUCCBASIS ( RIGHT(*=STATIC*) )
END;
SEARCHSECTION( ENTRY1.STANDARDIDTREE, LCP );
1:
FCP := LCP
END (*SEARCHID*);
(** GETBOUNDS COMPTYPES **)
PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER);
(*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
(*ASSUME (FSP <> NIL) AND (FSP↑.FORM <= SUBRANGE) AND (FSP <> INTPTR)
AND NOT COMPTYPES(REALPTR,FSP)*)
BEGIN
WITH FSP↑ DO
IF FORM = SUBRANGE
THEN
BEGIN
FMIN := MINV.IVAL; FMAX := MAXV.IVAL
END
ELSE
BEGIN
FMIN := 0;
IF FSP = ENTRY1.CHARPTR
THEN FMAX := 177B
ELSE
IF FCONST <> NIL
THEN FMAX := FCONST↑.VALUES.IVAL
ELSE FMAX := 0
END
END (*GETBOUNDS*) ;
FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
(*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE*)
VAR
NXT1,NXT2: CTP; COMP: BOOLEAN; LMIN,LMAX,I: INTEGER;
BEGIN
IF FSP1 = FSP2
THEN COMPTYPES := TRUE
ELSE
IF (FSP1 <> NIL) AND (FSP2 <> NIL)
THEN
IF FSP1↑.FORM = FSP2↑.FORM
THEN
CASE FSP1↑.FORM OF
SCALAR:
COMPTYPES := FALSE;
(* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
NOT RECOGNIZED TO BE COMPATIBLE*)
SUBRANGE:
COMPTYPES := COMPTYPES(FSP1↑.RANGETYPE,FSP2↑.RANGETYPE);
POINTER:
COMPTYPES := COMPTYPES(FSP1↑.ELTYPE,FSP2↑.ELTYPE);
POWER:
COMPTYPES := COMPTYPES(FSP1↑.ELSET,FSP2↑.ELSET);
ARRAYS:
BEGIN
GETBOUNDS (FSP1↑.INXTYPE,LMIN,LMAX);
I := LMAX-LMIN;
GETBOUNDS (FSP2↑.INXTYPE,LMIN,LMAX);
COMPTYPES := COMPTYPES(FSP1↑.AELTYPE,FSP2↑.AELTYPE)
AND (FSP1↑.ARRAYPF = FSP2↑.ARRAYPF) AND ( I = LMAX - LMIN )
END;
(*ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
BE COMPATIBLE. MAY GIVE TROUBLE FOR ENT OF STRINGCONSTANTS
-- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
BE THE SAME*)
RECORDS:
BEGIN
NXT1 := FSP1↑.FSTFLD; NXT2 := FSP2↑.FSTFLD; COMP := TRUE;
WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) DO
BEGIN
COMP := COMPTYPES(NXT1↑.IDTYPE,NXT2↑.IDTYPE) AND COMP;
NXT1 := NXT1↑.NEXT; NXT2 := NXT2↑.NEXT
END;
COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
AND (FSP1↑.RECVAR = NIL) AND (FSP2↑.RECVAR = NIL)
END;
(*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
IF NO VARIANTS OCCUR*)
FILES:
COMPTYPES := COMPTYPES(FSP1↑.FILTYPE,FSP2↑.FILTYPE)
END (*CASE*)
ELSE (*FSP1↑.FORM <> FSP2↑.FORM*)
IF FSP1↑.FORM = SUBRANGE
THEN COMPTYPES := COMPTYPES(FSP1↑.RANGETYPE,FSP2)
ELSE
IF FSP2↑.FORM = SUBRANGE
THEN COMPTYPES := COMPTYPES(FSP1,FSP2↑.RANGETYPE)
ELSE COMPTYPES := FALSE
ELSE COMPTYPES := TRUE
END (*COMPTYPES*) ;
(** NEXTBYTE PUTNEXTBYTE **)
FUNCTION NEXTBYTE(FBITSIZE: INTEGER ): INTEGER;
VAR
LVAL,J: INTEGER;
BEGIN
WITH GATTR DO
IF PACKFG
THEN
BEGIN
LVAL := 0;
IF FBITSIZE + GBITCOUNT > BITMAX
THEN
BEGIN
GADDR := GADDR + 1;
GBITCOUNT := 0
END;
IF FBITSIZE = BITMAX
THEN LVAL := BASIS↑[GADDR]
ELSE
WITH BYTECV DO
BEGIN
INTCONST := BASIS↑[GADDR];
FOR J := GBITCOUNT + 1 TO GBITCOUNT + FBITSIZE DO
LVAL := LVAL*2 + BITS[J]
END;
GBITCOUNT := GBITCOUNT + FBITSIZE;
NEXTBYTE := LVAL
END (*IF PACKFG*)
ELSE
BEGIN
IF GBITCOUNT > 0
THEN SYSTEM←ERROR(1);
NEXTBYTE := BASIS↑[GADDR];
GADDR := GADDR + 1; GBITCOUNT := 0
END
END (*NEXTBYTE*);
PROCEDURE PUTNEXTBYTE( FBITSIZE, FVAL: INTEGER );
VAR
J: INTEGER;
BEGIN
WITH GATTR, BYTECV DO
BEGIN
IF FBITSIZE + GBITCOUNT > BITMAX
THEN
BEGIN
GADDR := GADDR + 1; GBITCOUNT := 0
END;
INTCONST := BASIS↑[GADDR];
FOR J := GBITCOUNT + FBITSIZE DOWNTO GBITCOUNT+ 1 DO
BEGIN
BITS[J] := ORD(ODD(FVAL));
FVAL := FVAL DIV 2
END;
GBITCOUNT := GBITCOUNT + FBITSIZE;
BASIS↑[GADDR] := INTCONST
END
END (*PUTNEXTBYTE*);
(** LOAD GETFIELD SELECTOR **)
PROCEDURE LOAD;
(* LOAD VALUE, DESCRIBED BY GATTR, INTO GATTR.CVAL*)
BEGIN
WITH GATTR DO
IF KIND = VARBL
THEN
IF TYPTR <> NIL
THEN
IF TYPTR↑.FORM <= POINTER
THEN
BEGIN
KIND := EXPR; CVAL.IVAL := NEXTBYTE(GBITCOUNT)
END;
END (*LOAD*);
PROCEDURE GETFIELD( FCP:CTP );
BEGIN
WITH FCP↑, GATTR DO
BEGIN
IF KLASS <> FIELD
THEN SYSTEM←ERROR(3);
CASE PACKF OF
NOTPACK,
HWORDL:
BEGIN
GADDR := GADDR + FLDADDR; GBITCOUNT := 0
END;
HWORDR:
BEGIN
GADDR := GADDR + FLDADDR;
GBITCOUNT := 18
END;
PACKK:
WITH FLDBYTE DO
BEGIN
GADDR := GADDR + RELADDR;
GBITCOUNT := BITMAX - SBITS -PBITS
END
END (*CASE*);
PACKFG := PACKF <> NOTPACK;
TYPTR := IDTYPE
END (*WITH*)
END (*GETFIELD*);
PROCEDURE EXPRESSION; FORWARD;
PROCEDURE SELECTOR;
LABEL
1;
VAR
LCP: CTP;
LMIN, LMAX: INTEGER;
LATTR: ATTR;
INDEX, I, INDEXOFFSET, BYTESINWORD: INTEGER;
BEGIN
WHILE SY IN [LBRACK,ARROW,PERIOD] DO WITH GATTR DO
CASE SY OF
LBRACK:
BEGIN
REPEAT
IF TYPTR <> NIL
THEN
IF TYPTR↑.FORM <> ARRAYS
THEN
BEGIN
ERROR; WRITELN(TTY,'TYPE OF VARIABLE IS NOT ARRAY')
END;
INSYMBOL;
LATTR := GATTR;
EXPRESSION;
IF (TYPTR <> NIL) AND (LATTR.TYPTR<>NIL)
THEN
BEGIN
IF COMPTYPES( GATTR.TYPTR, LATTR.TYPTR↑.INXTYPE )
THEN WITH GATTR DO
BEGIN
LOAD;
INDEX := CVAL.IVAL;
GATTR := LATTR;
WITH TYPTR↑ DO
BEGIN
GETBOUNDS(INXTYPE, LMIN, LMAX );
INDEXOFFSET := INDEX - LMIN;
IF INDEXOFFSET < 0
THEN I := - INDEXOFFSET
ELSE
IF INDEX > LMAX
THEN
I:= INDEX - LMAX
ELSE
GOTO 1;
ERROR; WRITE(TTY,'ARRAY-INDEX BY ', I:LENGTH(I));
IF INDEXOFFSET < 0
THEN WRITELN(TTY, ' LESS THAN LOW BOUND')
ELSE WRITELN(TTY, ' GREATER THAN HIGH BOUND');
1:
IF ARRAYPF
THEN
BEGIN
PACKFG := TRUE;
BYTESINWORD := BITMAX DIV AELTYPE↑.BITSIZE; I := INDEXOFFSET MOD BYTESINWORD;
GADDR := GADDR + (INDEXOFFSET DIV BYTESINWORD);
IF INDEXOFFSET < 0
THEN
BEGIN
GADDR := GADDR-1;
I := I + BYTESINWORD
END;
GBITCOUNT := I * AELTYPE↑.BITSIZE
END
ELSE GADDR := GADDR + (AELTYPE↑.SIZE * INDEXOFFSET);
IF TYPTR <> NIL
THEN TYPTR := AELTYPE
END (*WITH TYPTR↑*)
END (*IF COMPTYPES*)
ELSE
BEGIN
ERROR; WRITELN(TTY,'INDEX-TYPE IS NOT COMPATIBLE WITH DECLARATION')
END
END (*IF TYPTR<>NIL*)
UNTIL SY <> COMMA;
IF SY = RBRACK
THEN INSYMBOL
ELSE
BEGIN
ERROR; WRITELN(TTY,'"]" EXPECTED')
END;
END;
PERIOD:
BEGIN
IF TYPTR <> NIL
THEN
IF TYPTR↑.FORM <> RECORDS
THEN
BEGIN
ERROR; WRITELN(TTY,'TYPE OF VARIABLE IS NOT RECORD')
END;
INSYMBOL;
IF SY = IDENT
THEN
BEGIN
IF TYPTR <> NIL
THEN
BEGIN
SEARCHSECTION(TYPTR↑.FSTFLD, LCP);
IF LCP = NIL
THEN
BEGIN
ERROR; WRITELN(TTY,'NO SUCH FIELD IN THIS RECORD')
END
ELSE GETFIELD(LCP)
END (*TYPTR <> NIL*);
INSYMBOL
END
ELSE
BEGIN
ERROR; WRITELN(TTY,'IDENTIFIER EXPECTED')
END
END (*PERIOD*);
ARROW:
BEGIN
INSYMBOL;
IF TYPTR <> NIL
THEN
CASE TYPTR↑.FORM OF
POINTER:
BEGIN
GADDR := NEXTBYTE(18);
IF GADDR = ORD(NIL)
THEN
BEGIN
ERROR; WRITELN(TTY,'POINTER IS NIL')
END
ELSE
IF (GADDR >= ORD(ACCUS)) OR
(GADDR <= ORD(ACRPOINT(ACCUS↑[0+15B],RIGHT)))
THEN
BEGIN
ERROR; WRITELN(TTY,'POINTER IS OUT OF HEAP')
END
ELSE
WITH HEAPCV DO
BEGIN
TYPTR := TYPTR↑.ELTYPE;
MERKBASIS:=ACRPOINT(GADDR-1,RIGHT);
CIVAL:=MERKBASIS↑[0];
IF (GADDR < ORD(CACR) )
AND (ORD(CIDTYPE) >= ORD(NIL) )
THEN
MAXADDR:=ORD(CACR)-1
ELSE MAXADDR:=ORD(NIL);
END (* WITH HEAPCV *);
END;
FILES:
BEGIN
GADDR := BASIS↑[GADDR];
TYPTR := TYPTR↑.FILTYPE
END;
OTHERS:
BEGIN
ERROR;
WRITELN(TTY,'TYPE OF VARIABLE MUST BE FILE OR POINTER')
END
END (*CASE FORM*);
PACKFG := FALSE; GBITCOUNT := 0
END (*ARROW*)
END (*CASE*)
END (*SELECTOR*);
(** VARIABLE **)
PROCEDURE VARIABLE;
VAR
LCP: CTP;
BEGIN
(*VARIABLE*)
SEARCHID(LCP);
INSYMBOL;
IF LCP = NIL
THEN
BEGIN
ERROR; WRITELN(TTY,'NOT FOUND')
END
ELSE
BEGIN
WITH LCP↑, GATTR DO
CASE KLASS OF
TYPES:
BEGIN
ERROR; WRITELN(TTY,'!TYPE')
END;
KONST:
BEGIN
KIND := CST; CVAL := VALUES;
TYPTR := IDTYPE
END;
VARS:
BEGIN
KIND := VARBL;
GADDR := VADDR + ORD(BASIS); BASIS := NULLPTR;
GBITCOUNT := 0;
IF VKIND = FORMAL
THEN GADDR := BASIS↑[GADDR];
TYPTR := IDTYPE; PACKFG := FALSE;
SELECTOR
END;
(*FIELD: WRITE(TTY,'NOT IMPL.; TYPE <RECORD>.<FIELD> ...');*)
PROC:
BEGIN
ERROR; WRITELN(TTY,'!PROCEDURE')
END;
FUNC:
BEGIN
ERROR; WRITELN(TTY,'!FUNCTION')
END
END (*CASE CLASS*)
END
END (*VARIABLE*);
(** EXPRESSION SIMPLEEXPRESSION TERM FACTOR **)
PROCEDURE EXPRESSION;
PROCEDURE SIMPLEEXPRESSION;
VAR
SIGNED: BOOLEAN;
LATTR: ATTR;
LOP: SYMBOL;
PROCEDURE TERM;
VAR
LATTR: ATTR;
PROCEDURE FACTOR;
BEGIN
CASE SY OF
IDENT:
VARIABLE;
INTCONST,
REALCONST,
CHARCONST:
WITH GATTR DO
BEGIN
KIND := CST; CVAL := VAL;
IF SY = INTCONST
THEN TYPTR := ENTRY1.INTPTR
ELSE
IF SY = REALCONST
THEN TYPTR := ENTRY1.REALPTR
ELSE TYPTR := ENTRY1.CHARPTR;
INSYMBOL
END;
STRINGCONST:
WITH GATTR DO
BEGIN
TYPTR := STRINGPTR;
KIND := VARBL; PACKFG := FALSE;
GADDR := ORD(STRING); GBITCOUNT := 0;
INSYMBOL
END;
NOTSY:
BEGIN
INSYMBOL; FACTOR;
WITH GATTR DO
IF TYPTR = ENTRY1.BOOLPTR
THEN
BEGIN
LOAD; CVAL.BVAL := NOT CVAL.BVAL
END
ELSE
BEGIN
ERROR; WRITELN(TTY,'TYPE IS NOT BOOLEAN')
END
END (* NOT *);
LPARENT:
BEGIN
INSYMBOL; EXPRESSION;
IF SY = RPARENT
THEN INSYMBOL
ELSE
BEGIN
ERROR;
WRITELN(TTY,'")" EXPECTED')
END
END (* ( *) ;
OTHERS:
BEGIN
ERROR; WRITELN(TTY,'FACTOR EXPECTED')
END
END (* CASE *)
END (*FACTOR*);
BEGIN (*TERM*)
FACTOR;
WHILE SY = MUL DO
BEGIN
INSYMBOL;
LOAD; LATTR := GATTR;
FACTOR; LOAD;
IF COMPTYPES(LATTR.TYPTR,ENTRY1.INTPTR) AND
COMPTYPES(GATTR.TYPTR,ENTRY1.INTPTR)
THEN GATTR.CVAL.IVAL := GATTR.CVAL.IVAL * LATTR.CVAL.IVAL
ELSE
BEGIN
ERROR; WRITELN(TTY,'OPERANDS MUST BE OF TYPE INTEGER')
END
END
END (*TERM*);
BEGIN (*SIMPLEEXPRESSION*)
IF SY IN [PLUS,MINUS]
THEN WITH GATTR DO
BEGIN
SIGNED := SY=MINUS ;
INSYMBOL; TERM;
IF COMPTYPES(TYPTR,ENTRY1.INTPTR) OR COMPTYPES(TYPTR,ENTRY1.REALPTR)
THEN
BEGIN
IF SIGNED
THEN
BEGIN
LOAD; CVAL.IVAL := - CVAL.IVAL
END
END
ELSE
BEGIN
ERROR; WRITELN(TTY,'NO SIGN ALLOWED HERE')
END
END (*MINUS*)
ELSE TERM;
WHILE SY IN [PLUS,MINUS] DO
BEGIN
LOP := SY; INSYMBOL;
LOAD; LATTR := GATTR;
TERM; LOAD;
IF COMPTYPES(LATTR.TYPTR,ENTRY1.INTPTR) AND
COMPTYPES(GATTR.TYPTR,ENTRY1.INTPTR)
THEN
IF LOP = PLUS
THEN GATTR.CVAL.IVAL := LATTR.CVAL.IVAL + GATTR.CVAL.IVAL
ELSE GATTR.CVAL.IVAL := LATTR.CVAL.IVAL - GATTR.CVAL.IVAL
ELSE
BEGIN
ERROR; WRITELN(TTY,'OPERANDS MUST BE OF TYPE INTEGER')
END
END
END (*SIMPLEEXPRESSION*);
BEGIN
SIMPLEEXPRESSION
END (*EXPRESSION*);
(** SHIFTED←OUT WRITESCALAR PUTSIXBIT **)
PROCEDURE SHIFTED←OUT(NAME:ALFA);
LABEL
1;
VAR
RUN:INTEGER;
BEGIN
FOR RUN := 1 TO 10 DO
IF NAME[RUN]=' '
THEN GOTO 1
ELSE WRITE(TTY,NAME[RUN]);
1:
CHCNT:=CHCNT+RUN-1;
END (*SHIFTED←OUT*);
PROCEDURE WRITESCALAR(FVAL:INTEGER; FSP: STP);
VAR
LCP: CTP; LENG,MAXVAL,MINVAL: INTEGER;
LVALU: VALU;
BEGIN
LENG:=0;
IF FSP <> NIL
THEN WITH FSP↑ DO
CASE FORM OF
SCALAR:
IF SCALKIND=STANDARD
THEN
IF FSP=ENTRY1.INTPTR
THEN
BEGIN
LENG := LENGTH(FVAL); WRITE(TTY, FVAL:LENG)
END
ELSE
IF FSP=ENTRY1.REALPTR
THEN WITH LVALU DO
BEGIN
IVAL := FVAL;
WRITE(TTY, RVAL); LENG := 17
END
ELSE (*==>CHARPTR*)
BEGIN
IF FSP <> ENTRY1.CHARPTR
THEN SYSTEM←ERROR(4)
ELSE
IF (FVAL<0) OR (FVAL>177B)
THEN
BEGIN
WRITE(TTY,FVAL:LENGTH(FVAL),' (ILL. CHAR.)');LENG:=13+LENGTH(FVAL);
END
ELSE
BEGIN
IF (FVAL<40B) OR (FVAL=177B)
THEN
BEGIN
ASCII←CHANGE.IVAL := FVAL;
IF FVAL = 177B
THEN ASCII←CHANGE.IVAL := 40B;
WRITE(TTY,ASCII←CHANGE.MNEMO:3); LENG := 3
END
ELSE
BEGIN
WRITE(TTY,'''',CHR(FVAL),''''); LENG := 3
END
END;
END
ELSE (*SCALKIND==>DECLARED*)
BEGIN
LCP := FCONST;
IF FVAL >= 0
THEN WHILE LCP↑.VALUES.IVAL > FVAL DO LCP := LCP↑.NEXT;
WITH LCP↑ DO
IF VALUES.IVAL <> FVAL
THEN
BEGIN
WRITESCALAR(FVAL,ENTRY1.INTPTR); WRITE(TTY,'(OUT OF RANGE)'); LENG := 14
END
ELSE
SHIFTED←OUT(NAME);
END;
SUBRANGE:
BEGIN
WRITESCALAR(FVAL,RANGETYPE); LENG := 0;
IF NOT COMPTYPES(ENTRY1.REALPTR,RANGETYPE)
THEN
BEGIN
IF RANGETYPE<>ENTRY1.INTPTR
THEN
GETBOUNDS(RANGETYPE,MINVAL,MAXVAL);
IF (FVAL <= MAXVAL) AND (FVAL >= MINVAL) OR (ENTRY1.INTPTR=RANGETYPE)
THEN
BEGIN
GETBOUNDS(FSP,MINVAL,MAXVAL);
IF (FVAL > MAXVAL) OR (FVAL < MINVAL)
THEN
BEGIN
WRITE(TTY,'(OUT OF SUBRANGE)');
LENG:=17;
END (* IF ..>...<.. *);
END (* IF ..=<..=>..=.. *);
END (* IF COMPTYPES *);
END;
POINTER:
IF FVAL = ORD(NIL)
THEN
BEGIN
WRITE(TTY,'NIL'); LENG := 3
END
ELSE
BEGIN
WRITE(TTY,FVAL:6:O,'B');
IF (FVAL < ACCUS↑[0+15B]) OR (FVAL > ORD(ACCUS))
THEN
BEGIN
WRITE(TTY,'(OUT OF HEAP)');
LENG:=20;
END
ELSE
LENG:=7;
END;
OTHERS:
SYSTEM←ERROR(5)
END (*CASE*);
CHCNT := CHCNT + LENG;
TABS:=TRUE;
END (*WRITESCALAR*);
PROCEDURE PUTSIXBIT(FSIXBIT:SIXBIT;FIX:INTEGER);
VAR
I:INTEGER;
BEGIN
FOR I:=1 TO FIX DO
WRITE(TTY,CHR(FSIXBIT[I]+40B));
CHCNT:=CHCNT+FIX;
END;
(** WRITESTRUCTURE WRITEFIELDLIST **)
PROCEDURE WRITESTRUCTURE( FSP: STP );
TYPE
ASCII=PACKED ARRAY[1..5] OF CHAR;
THREEBIT=PACKED ARRAY[1..12] OF 0..7;
HALFWORD=PACKED ARRAY[LEFTORRIGHT] OF BITS18;
FILBLKTYP=RECORD
FILEOF,FILPTR:INTEGER;
FILEOL:BOOLEAN;
FILSTA,FILCLS,FILOUT,FILIN,FILENT,
FILLKP,FILOPN:INTEGER;
FILDEV:SIXBIT;
FILPBH:HALFWORD;
FILEXT,FILNAM:SIXBIT;
FILPPN,FILPROT:THREEBIT;
FILBTC,FILBTP,FILBFH:INTEGER;
FILLNR:ASCII;
FILCMP,FILCNT:INTEGER
END;
VAR
STINX, INX, I : INTEGER;
LLMAX, CURRCOMPO, LMIN, LMAX, LENG, LSPACE: INTEGER;
OATTR, LATTR: ATTR;
ILLSTRING,NEXTEQ, LASTEQ, ZERO, NOCOMMA: BOOLEAN;
SETWANDEL: RECORD
CASE BOOLEAN OF
FALSE: (CONST1: INTEGER; CONST2: INTEGER);
TRUE: (MASK: SET OF 0..BASEMAX)
END;
FILBLKWANDEL:RECORD
CASE BOOLEAN OF
TRUE:(INT:INTEGER);
FALSE:(PTR:↑FILBLKTYP)
END;
PROCEDURE WRITEFIELDLIST(FNEXTFLD: CTP; FRECVAR: STP);
LABEL
1;
VAR
LSP: STP;
J,LMIN,LMAX : INTEGER;
LATTR : ATTR;
TAGF : CTP;
BEGIN
LATTR := GATTR; TAGF := NIL;
IF FRECVAR <> NIL
THEN
IF FRECVAR↑.FORM = TAGFWITHID
THEN TAGF := FRECVAR↑.TAGFIELDP;
WHILE (FNEXTFLD <> NIL) AND (FNEXTFLD <> TAGF) DO
BEGIN
NEWLINE;
GETFIELD(FNEXTFLD);
WITH FNEXTFLD↑ DO
BEGIN
SHIFTED←OUT(NAME);WRITE(TTY,'=');
CHCNT:=CHCNT+1;
NL := TRUE;
LEFTSPACE:=LEFTSPACE+2;
WRITESTRUCTURE(IDTYPE);
LEFTSPACE:=LEFTSPACE-2;
FNEXTFLD := NEXT
END;
IF FNEXTFLD<>NIL
THEN
WITH FNEXTFLD↑.IDTYPE↑ DO
IF FORM=ARRAYS
THEN
BEGIN
GETBOUNDS(INXTYPE,LMIN,LMAX);
TABS:=ARRAYPF AND TABS AND
COMPTYPES(AELTYPE , ENTRY1.CHARPTR) AND
(LMAX-LMIN <= 20 )
END
ELSE
TABS:=TABS AND (FORM<=POINTER)
ELSE
TABS:=FALSE;
GATTR := LATTR
END (*WHILE*);
IF TAGF <> NIL
THEN
BEGIN
WITH TAGF↑ DO
BEGIN
NEWLINE;
SHIFTED←OUT(NAME);
WRITE(TTY,'=');
CHCNT:=CHCNT+1;
GETFIELD( TAGF );
J := NEXTBYTE(IDTYPE↑.BITSIZE);
WRITESCALAR(J, IDTYPE);
WRITE(TTY,' (TAGFIELD)');
CHCNT:=CHCNT+11;
END;
LSP := FRECVAR↑.FSTVAR;
TABS:=FALSE;
LOOP
IF LSP = NIL
THEN
BEGIN
WRITE(TTY,'(NO CORRESP.VARIANT)'); GOTO 1
END
EXIT IF LSP↑.VARVAL.IVAL = J;
LSP := LSP↑.NXTVAR
END (*LOOP*);
WITH LSP↑ DO
BEGIN
IF FORM <> VARIANT
THEN
SYSTEM←ERROR(6);
GATTR := LATTR;
WRITEFIELDLIST( FIRSTFIELD, SUBVAR );
TABS:=FALSE;
END;
1:
END
END (*WRITEFIELDLIST*);
BEGIN
(*WRITESTRUCTURE*)
IF FSP <> NIL
THEN WITH FSP↑ DO
IF FORM <= POINTER
THEN WRITESCALAR ( NEXTBYTE(BITSIZE), FSP )
ELSE
BEGIN
LATTR := GATTR;
WITH GATTR DO
BEGIN
IF GBITCOUNT > 0
THEN
BEGIN
GADDR := GADDR + 1; GBITCOUNT := 0
END;
CASE FORM OF
POWER:
BEGIN
NOCOMMA := TRUE; WRITE(TTY, '['); LENG := 1;
WITH SETWANDEL DO
BEGIN
CONST1 := BASIS↑[GADDR]; CONST2 := BASIS↑[GADDR+1];
FOR INX := 0 TO BASEMAX DO
IF INX IN MASK
THEN
BEGIN
IF NOCOMMA
THEN NOCOMMA := FALSE
ELSE WRITE(TTY,',');
LENG := LENG + 1;
IF COMPTYPES(ELSET,ENTRY1.CHARPTR)
THEN I := INX + OFFSET
ELSE I := INX;
WRITESCALAR(I,ELSET)
END
END (*WITH SETWANDEL*);
WRITE(TTY,']' ); CHCNT := CHCNT + LENG;
TABS:=FALSE;
END (*POWER*);
ARRAYS:
BEGIN
ILLSTRING:=FALSE;
GETBOUNDS(INXTYPE, LMIN, LMAX );
IF ( GADDR > ORD(ACRPOINT(ACCUS↑[0+15B],RIGHT))) (* DYNAMIC ALLOCATED *)
AND ( GADDR <= ORD(NIL) ) (* NOT A CONSTANT *)
THEN
BEGIN
IF MAXADDR > ORD(ACCUS)
THEN MAXADDR := ORD(ACCUS);
IF ARRAYPF
THEN
LLMAX := (MAXADDR-GADDR+1) * (36 DIV AELTYPE↑.BITSIZE) + LMIN - 1
ELSE
LLMAX := (MAXADDR-GADDR+1) DIV AELTYPE↑.SIZE + LMIN - 1;
IF LLMAX < LMAX
THEN LMAX := LLMAX;
END;
LENG := LMAX - LMIN + 1 ;
IF COMPTYPES(AELTYPE , ENTRY1.CHARPTR) AND ARRAYPF AND (LENG<121)
THEN
BEGIN
POINTERCV.ADDR := GADDR;
INX:=1;
WITH POINTERCV DO
WHILE (INX<=LENG) DO
IF (STRINGPTR↑[INX] < CHR(40B (*' '*))) OR (STRINGPTR↑[INX] > CHR(172B (* LOWER-Z *)))
THEN
INX:=122
ELSE INX:=INX+1;
IF INX = 122
THEN
BEGIN
ILLSTRING:=TRUE;
WRITE(TTY,'STRING CONT. ILL. CHAR');
TABS:=FALSE;
LEFTSPACE:=LEFTSPACE+2;
NEWLINE;
WRITE(TTY,'THE COMPONENTS ARE:');
NL:=TRUE;
END;
END (* TEST ILLSTRING *);
IF COMPTYPES(AELTYPE , ENTRY1.CHARPTR) AND ARRAYPF AND (LENG<121) AND NOT ILLSTRING
THEN (*STRING*)
BEGIN
WRITE ( TTY, '''', POINTERCV.STRINGPTR↑ : LENG, '''' ) ;
CHCNT := CHCNT + LENG + 2;
TABS:= (LENG <= 20);
END (*STRING*)
ELSE
BEGIN
TABS:=FALSE;
PACKFG:=ARRAYPF;
LASTEQ:=FALSE;
FOR INX:= LMIN TO LMAX DO
BEGIN
IF INX=LMAX
THEN NEXTEQ:=FALSE
ELSE
IF AELTYPE↑.FORM <= POINTER
THEN
BEGIN
OATTR:=GATTR;
CURRCOMPO:=NEXTBYTE(AELTYPE↑.BITSIZE);
NEXTEQ:=CURRCOMPO = NEXTBYTE(AELTYPE↑.BITSIZE);
GATTR:=OATTR;
END
ELSE
BEGIN
NEXTEQ:=TRUE;I:=0;
LOOP
NEXTEQ:=(BASIS↑[GADDR+I] = BASIS↑[GADDR+AELTYPE↑.SIZE+I]);
EXIT IF NOT NEXTEQ OR (I = AELTYPE↑.SIZE-1);
I:=I+1;
END;
END (* FORM>POINTER *);
IF NOT(LASTEQ AND NEXTEQ)
THEN
BEGIN
IF NL
THEN NEWLINE
ELSE NL:=TRUE;
WRITE(TTY,'['); WRITESCALAR(INX,INXTYPE);
WRITE(TTY,']'); CHCNT:=CHCNT+2;
END;
IF NOT NEXTEQ
THEN
BEGIN
WRITE(TTY,'=');CHCNT:=CHCNT+1;
LEFTSPACE:=LEFTSPACE + 3;
NL:=TRUE;
WRITESTRUCTURE(AELTYPE);
LEFTSPACE:=LEFTSPACE - 3;
END
ELSE
BEGIN
IF NOT LASTEQ
THEN
BEGIN
WRITE(TTY,'..');
CHCNT:=CHCNT+2;
NL:=FALSE;
END;
IF AELTYPE↑.FORM <= POINTER
THEN CURRCOMPO:=NEXTBYTE(AELTYPE↑.BITSIZE)
ELSE GADDR:=GADDR+AELTYPE↑.SIZE;
END (* NEXTEQ *);
LASTEQ:=NEXTEQ;
END (* FOR *);
TABS:=FALSE;
IF ILLSTRING
THEN LEFTSPACE := LEFTSPACE - 2;
END (* NOT STRING *);
END (*ARRAYS*);
RECORDS:
BEGIN
WRITE(TTY,'RECORD');
LSPACE := LEFTSPACE; LEFTSPACE := CHCNT + 1;
TABS:=FALSE;
WRITEFIELDLIST(FSTFLD,RECVAR);
TABS:=FALSE;
LEFTSPACE := LEFTSPACE - 1; NEWLINE;
WRITE(TTY,'END');
LEFTSPACE := LSPACE;
END;
FILES:
WITH FILBLKWANDEL DO
BEGIN
IF NL
THEN
NEWLINE;
TABS:=TRUE;
INT:=GADDR;
WITH PTR↑, GATTR DO
IF (FILPBH[LEFT]=0) AND (FILPBH[RIGHT]=0)
THEN
BEGIN
WRITE(TTY,' FILE NOT OPENED');
END
ELSE
BEGIN
SHIFTED←OUT('DEVICE: ');
PUTSIXBIT(FILDEV,6);
NEWLINE;
SHIFTED←OUT('NAME: ');
PUTSIXBIT(FILNAM,6);
SHIFTED←OUT('. ');
PUTSIXBIT(FILEXT,3);
NEWLINE;
SHIFTED←OUT('PPN:[ ');
STINX:=1;
LOOP
ZERO:=TRUE;
FOR INX:=STINX TO STINX+5 DO
IF NOT(ZERO AND (FILPPN[INX]=0)) OR (INX=STINX+5)
THEN
BEGIN
ZERO:=FALSE;
WRITE(TTY,CHR(FILPPN[INX]+ORD('0')));
CHCNT:=CHCNT+1;
END;
EXIT IF STINX=7;
STINX:=7;WRITE(TTY,',');
END;
WRITE(TTY,']');CHCNT:=CHCNT+2;
NEWLINE;
SHIFTED←OUT('PROT:< ');
FOR INX:=1 TO 3 DO
WRITE(TTY,CHR(FILPROT[INX]+60B));
WRITE(TTY,'>');
CHCNT:=CHCNT+4;
NEWLINE;
SHIFTED←OUT('STATUS: ');
IF FILSTA=0
THEN SHIFTED←OUT('ASCII ')
ELSE SHIFTED←OUT('BINARY ');
NEWLINE;
SHIFTED←OUT('MODE(I/O):');
IF FILPBH[LEFT]<>0
THEN SHIFTED←OUT('OUTPUT ')
ELSE SHIFTED←OUT('INPUT ');
NEWLINE;
IF FILPBH[LEFT]=0
THEN
BEGIN
IF FILSTA=0
THEN
BEGIN
IF FILLNR<>'-----'
THEN
BEGIN
SHIFTED←OUT('LINENR.: ');
WRITE(TTY,FILLNR);
CHCNT:=CHCNT+5;
NEWLINE;
END;
WRITE(TTY,'EOLN:',FILEOL:5);
CHCNT:=CHCNT+10;
NEWLINE;
END (* FILSTA = 0 *);
WRITE(TTY,'EOF:',(FILEOF<>0):5);
CHCNT:=CHCNT+9;
NEWLINE;
END (* FILPBH[LEFT]=0 *);
GADDR:=FILPTR;
TYPTR := TYPTR↑.FILTYPE;
TABS:=FALSE;
IF CHCNT<>LEFTSPACE
THEN NEWLINE;
SHIFTED←OUT('COMPONENT:');
NL:=TRUE;
WRITESTRUCTURE(TYPTR);
END (* WITH PTR↑ *);
TABS:=FALSE;
END (* FILBLKWANDEL *)
END (*CASE FORM*)
END (*WITH GATTR*);
GATTR := LATTR;
WITH GATTR DO
BEGIN
GADDR := GADDR + SIZE; GBITCOUNT := 0
END
END (*IF FORM > POINTER*)
END (*WRITESTRUCTURE*);
(** ASSIGNMENT **)
PROCEDURE ASSIGNMENT;
VAR
LATTR: ATTR;
LSP: STP;
BYTE, I: INTEGER;
BEGIN
IF GATTR.KIND <> VARBL
THEN
BEGIN
ERROR; WRITELN(TTY,'ASSIGNMENT ALLOWED TO VARIABLES ONLY')
END
ELSE
BEGIN
LATTR := GATTR;
EXPRESSION;
IF SY <> EOLSY
THEN
BEGIN
ERROR; WRITELN(TTY,'<CR><LF> EXPECTED')
END
ELSE
IF COMPTYPES( LATTR.TYPTR, GATTR.TYPTR )
THEN
BEGIN
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL)
THEN
IF LATTR.PACKFG
THEN
BEGIN
LOAD; BYTE := GATTR.CVAL.IVAL;
GATTR := LATTR;
PUTNEXTBYTE( GATTR.TYPTR↑.BITSIZE, BYTE )
END (* IF PACKFG *)
ELSE
IF GATTR.KIND <> VARBL
THEN BASIS↑[LATTR.GADDR] := GATTR.CVAL.IVAL
ELSE
IF GATTR.PACKFG
THEN BASIS↑[LATTR.GADDR] := NEXTBYTE( GATTR.TYPTR↑.BITSIZE )
ELSE FOR I := 0 TO LATTR.TYPTR↑.SIZE - 1 DO
BASIS↑[LATTR.GADDR + I ] := BASIS↑[ GATTR.GADDR + I ]
END (* IF COMPTYPES *)
ELSE
BEGIN
ERROR; WRITELN(TTY, 'TYPE-CONFLICT IN ASSIGNMENT' )
END
END (* KIND=VARIABLE *)
END (*ASSIGNMENT*);
(** STOPSEARCH PAGEVALUE LINEVALUE BREAKPOINT GETLINPAG **)
FUNCTION STOPSEARCH(FLINE:ADDRRANGE):INTEGER;
LABEL
1;
VAR
I: INTEGER;
BEGIN
FOR I := 1 TO STOPMAX DO WITH STOPTABLE[I] DO
IF (PAGE=GPAGE) AND (THISLINE=FLINE)
THEN
BEGIN
STOPSEARCH := I;
GOTO 1(*EXIT*)
END;
STOPSEARCH := 0; (*NOT FOUND*)
1:
END (*STOPSEARCH*);
FUNCTION PAGEVALUE(FPAGER: PAGEELEM): INTEGER;
BEGIN
WITH FPAGER DO PAGEVALUE := AC*16 + INXREG
END (*PAGEVALUE*);
FUNCTION LINEVALUE ( VAR FLINER: LINEELEM; FLINE: INTEGER) : INTEGER;
LABEL
1;
VAR
I: INTEGER;
BEGIN
WHILE FLINER.CODE = 260B(*PUSHJ*) DO
BEGIN
I := STOPSEARCH( FLINE );
IF I = 0
THEN
BEGIN
WRITELN(TTY,'$ STOPTABLE DESTROYED'); LINEVALUE := -1; GOTO 1
END;
FLINER.CONSTANT1 := STOPTABLE[I] . ORIGINALCONT
END (*PUSHJ*);
WITH FLINER DO
IF CODE = 320B(*JUMP*)
THEN LINEVALUE := FLINE - ( AC + 16*INXR )
ELSE (*SKIPA*)
BEGIN
IF CODE <> 334B(*SKIPA*)
THEN
BEGIN
SYSTEM←ERROR(7);
LINEVALUE := -1; GOTO 1
END;
IF ABSLINE = 777777B
THEN LINEVALUE := -1
ELSE LINEVALUE := ABSLINE
END;
1:
END (*LINEVALUE*) ;
PROCEDURE BREAKPOINT;
LABEL
1;
VAR
LINENR, I: INTEGER;
PAGER: PAGEELEM; LLE: LINEELEM;
LLINE,LPAGE: INTEGER;
OLDLINE: INTEGER;
OLDADDR: ↑LINEELEM;
CHANGEPTR: ↑LINEELEM;
FUNCTION GETLINPAG: BOOLEAN; (*READS LINENUMBER AND PAGENUMBER*)
BEGIN
GETLINPAG := FALSE;
IF SY <> INTCONST
THEN WRITELN(TTY,'$ ILL. LINENR.')
ELSE
BEGIN
LINENR := VAL.IVAL; GPAGE := 1(*DEFAULT*);
INSYMBOL;
IF SY = SLASHSY
THEN
BEGIN
INSYMBOL;
IF SY <> INTCONST
THEN WRITELN(TTY,'$ ILL. PAGENR.')
ELSE
BEGIN
GPAGE := VAL.IVAL; INSYMBOL
END
END;
IF SY <> EOLSY
THEN WRITELN(TTY,'$ COMMAND ERROR')
ELSE GETLINPAG := TRUE
END
END (*GETLINPAG*);
BEGIN
(*BREAKPOINT*)
CASE SY OF
IDENT:
IF ID = 'LIST '
THEN
BEGIN
INSYMBOL;
IF SY <> EOLSY
THEN WRITELN(TTY,'$ COMMAND ERROR')
ELSE FOR I := 1 TO STOPMAX DO WITH STOPTABLE[I] DO
IF PAGE > 0
THEN WRITELN(TTY,'$ ', THISLINE:5, '/', PAGE:LENGTH(PAGE))
END
ELSE
WRITELN(TTY,'$ COMMAND ERROR');
NOTSY:
BEGIN
INSYMBOL;
IF GETLINPAG
THEN
BEGIN
I:=STOPSEARCH(LINENR);
IF I = 0
THEN WRITELN(TTY, '$ ?NO STOP')
ELSE WITH STOPTABLE[I] DO
BEGIN
PAGE := 0;
PROTECTION(FALSE);
THISADDR↑.CONSTANT1 := ORIGINALCONT;
PROTECTION(TRUE);
THISADDR := NIL
END
END
END;
INTCONST:
IF GETLINPAG AND ( STOPSEARCH(LINENR) = 0 (*A NEW STOP*) )
THEN
BEGIN
STOPNR := 1;
WHILE STOPTABLE[STOPNR].PAGE <> 0 DO STOPNR := STOPNR + 1;
IF STOPNR > STOPMAX
THEN WRITELN(TTY,'$ TOO MUCH STOPS')
ELSE
BEGIN
(*EXECUTE STOP*)
(*1.STEP: SEARCH PAGE*)
PAGER := ENTRY1.LASTPAGEELEM;
LPAGE := PAGEVALUE(PAGER);
IF LPAGE < GPAGE
THEN WRITELN(TTY,'$ PAGENR. TOO LARGE')
ELSE
BEGIN
WHILE LPAGE > GPAGE DO
BEGIN
PAGER := PAGER.PAGPTR↑;
LPAGE := PAGEVALUE(PAGER)
END;
IF LPAGE <> GPAGE
THEN
BEGIN
WRITELN(TTY,'$ CAN''T STOP ON THIS PAGE'); GOTO 1
END;
WITH LLE, PAGER DO
BEGIN
LLINE := LASTLINE; ADP := LASTSTOP
END;
IF LLINE < LINENR
THEN WRITELN(TTY,'$ LINENR. TOO LARGE')
ELSE
BEGIN
WHILE LLINE > LINENR DO
BEGIN
OLDLINE := LLINE; OLDADDR := LLE.ADP;
LLE := LLE.ADP↑;
LLINE := LINEVALUE ( LLE, LLINE )
END;
IF LLINE <> LINENR
THEN
BEGIN
WRITE(TTY,'$ NEXT POSSIBLE: ',OLDLINE:LENGTH(OLDLINE),' (Y OR N)? ');
BREAK; READLN(TTY);
INSYMBOL;
IF (SY <> IDENT) OR (ID[1] <> 'Y') OR (STOPSEARCH(OLDLINE) <> 0)
THEN GOTO 1;
LLE.ADP := OLDADDR; LLINE := OLDLINE
END;
CHANGEPTR := LLE.ADP;
WITH STOPTABLE[STOPNR] DO
BEGIN
THISLINE := LLINE; PAGE := GPAGE;
ORIGINALCONT := CHANGEPTR↑.CONSTANT1;
THISADDR := CHANGEPTR
END;
PROTECTION(FALSE);
CHANGEPTR↑.CONSTANT1 := ENTRY2.STOPPY;
PROTECTION(TRUE)
END
END
END;
1:
END (*INTCONST*);
OTHERS:
WRITELN(TTY,'$ COMMAND ERROR')
END (*CASE*)
END (*BREAKPOINT*);
(** LINEINTERVAL STOPMESSAGE TRACEOUT ONE←VAR←OUT **)
PROCEDURE LINEINTERVAL(FADDR: ADDRRANGE; VAR LIN1,LIN2,PAG: INTEGER);
VAR
PAGER: PAGEELEM; LINER: LINEELEM;
BEGIN
PAGER := ENTRY1.LASTPAGEELEM;
WHILE ORD(PAGER.PAGPTR) > FADDR DO
PAGER := PAGER.PAGPTR↑;
LINER.ADP := PAGER.LASTSTOP;
PAG := PAGEVALUE(PAGER); LIN2 := PAGER.LASTLINE;
LIN1 := LIN2;
WHILE ORD ( LINER.ADP ) > FADDR DO
BEGIN
LINER := LINER.ADP↑;
LIN2 := LIN1;
LIN1 := LINEVALUE(LINER,LIN2)
END;
IF LIN1<0
THEN LIN1 := 0
END (*LINEINTERVAL*);
PROCEDURE STOPMESSAGE(FADDR: ADDRRANGE);
VAR
LIN1, LIN2, PAG: INTEGER;
BEGIN
LINEINTERVAL(FADDR,LIN1,LIN2,PAG);
WRITELN(TTY, '$ STOP IN ', LIN1:LENGTH(LIN1), '/', PAG:LENGTH(PAG), ':',LIN2:LENGTH(LIN2) )
END (*STOPMESSAGE*) ;
PROCEDURE TRACEOUT;
VAR
I: 0:5; LCP: CTP;
LADDR: ADDRRANGE;
LIN1, LIN2, PAG, MAXNAMES: INTEGER;
BEGIN
TABS:=FALSE;
IF DUMP
THEN
BEGIN
NEWLINE;
WRITELN(TTY,' ':39,'PROCEDURE BACKTRACING');
WRITE(TTY,'$',' ':40,'=====================');
NEWLINE;
WRITELN(TTY);MAXNAMES:=5;
END
ELSE
MAXNAMES:=2;
FIRSTBASIS; I := 0; LEFTSPACE := 0;
LADDR := ENTRY2.STATUS.RETURNADDR;
WRITE(TTY,'$ ');
LOOP
LINEINTERVAL ( LADDR, LIN1, LIN2, PAG ) ;
WRITE(TTY,LIN1:5,'/',PAG:LENGTH(PAG),' ')
EXIT IF BASIS = NULLPTR;
LCP := IDTREE;
IF LCP<>NIL
THEN
WRITE(TTY, LCP↑.NEXT↑.NAME )
ELSE
WRITE(TTY,'''NO NAME'' ');
IF I = MAXNAMES
THEN
BEGIN
NEWLINE; I := 0
END
ELSE
BEGIN
WRITE(TTY,' ← '); I := I + 1
END;
LADDR := ORD ( ACRPOINT(BASIS↑[0]-1,RIGHT) );
SUCCBASIS( LEFT(*=DYNAMIC*) )
END;
WRITELN(TTY, 'MAIN')
END (*TRACEOUT*);
PROCEDURE ONE←VAR←OUT(LCP:CTP);
BEGIN
WITH LCP↑,GATTR DO
BEGIN
KIND:=VARBL;
GADDR:=VADDR+ORD(MERKBASIS);
GBITCOUNT:=0;
IF VKIND=FORMAL
THEN
GADDR:=NULLPTR↑[GADDR];
TYPTR:=IDTYPE;
PACKFG:=FALSE;
SHIFTED←OUT(NAME);
WRITE(TTY,'=');
CHCNT:=CHCNT+1;
IF IDTYPE↑.FORM > POWER
THEN
BEGIN
NL:=TRUE;
LEFTSPACE:=2;
END;
WRITESTRUCTURE(IDTYPE);
IF IDTYPE↑.FORM >= POWER
THEN
BEGIN
LEFTSPACE:=0;
TABS:=FALSE;
NEWLINE;
END;
NEWLINE;
END (* WITH *);
END (* ONE←VAR←OUT *);
(** SECTION←OUT OUT **)
PROCEDURE SECTION←OUT(LCP:CTP;FFORMSET:FORMSET);
BEGIN
WITH LCP↑ DO
BEGIN
IF LLINK<>NIL
THEN
SECTION←OUT(LLINK,FFORMSET);
IF (KLASS=VARS) AND (IDTYPE↑.FORM IN FFORMSET)
THEN
ONE←VAR←OUT(LCP);
IF RLINK<>NIL
THEN
SECTION←OUT(RLINK,FFORMSET);
END (* WITH *);
END (* SECTION←OUT *);
PROCEDURE OUT(SIDE:LEFTORRIGHT);
VAR
CALLCNT:INTEGER;
TREEPNT:CTP;
LOWESTDYNAMICBASIS,STATICBASIS:ACR;
VARSOUT:BOOLEAN;
BEGIN
CALLCNT:=1;
CHCNT:=0;
TABS:=FALSE;
LOWESTDYNAMICBASIS:=MERKBASIS;
FIRSTBASIS;
STATICBASIS:=BASIS;
LOOP
MERKBASIS:=BASIS;
TREEPNT:=IDTREE;
BASIS:=NULLPTR;
VARSOUT:=TRUE;
IF MERKBASIS=NULLPTR
THEN
WRITE(TTY,' * * * * * * * * MAIN')
ELSE
IF TREEPNT=NIL
THEN
WRITE(TTY,'P R O C E D U R E ''NO NAME'' ')
ELSE
IF TREEPNT↑.NEXT <> NIL
THEN
IF TREEPNT↑.NEXT↑.KLASS = FUNC
THEN WRITE(TTY,'F U N C T I O N ',TREEPNT↑.NEXT↑.NAME)
ELSE WRITE(TTY,'P R O C E D U R E ',TREEPNT↑.NEXT↑.NAME);
NEWLINE;
WRITE(TTY,'- - - - - - - - - - - - - - - -');
NEWLINE;
IF (SIDE = LEFT) AND (STATICBASIS = MERKBASIS) AND (MERKBASIS <> NULLPTR)
THEN
BEGIN
WRITE(TTY,'THE FOLLOWING VARIABLES ARE VALID');NEWLINE;
WRITE(TTY,' IN THE INTERRUPTED PROCEDURE ');
NEWLINE;NEWLINE;
BASIS:=STATICBASIS;
SUCCBASIS(RIGHT);
STATICBASIS:=BASIS;
BASIS:=NULLPTR;
END
ELSE
IF (SIDE = RIGHT) AND (ORD(LOWESTDYNAMICBASIS) <= ORD(MERKBASIS))
THEN
BEGIN
WRITE(TTY,'LOOK ABOVE ( VAR. OF CALLED PROC.) ');
NEWLINE; VARSOUT:=FALSE;
END;
IF (TREEPNT = NIL) AND VARSOUT
THEN
BEGIN
WRITE(TTY,' THERE IS NO INFORMATION ABOUT' );NEWLINE;
WRITE(TTY,' THIS PART OF THE PROGRAMM ( LOCAL D- ??)');
NEWLINE; VARSOUT:=FALSE;
END (* TREEPTR=NIL ....*);
IF VARSOUT AND (MERKBASIS<>NULLPTR)
THEN TREEPNT:=TREEPNT↑.LLINK;
IF VARSOUT
THEN
IF TREEPNT<>NIL
THEN
BEGIN
SECTION←OUT(TREEPNT,[SCALAR,SUBRANGE,POINTER]);
TABS:=FALSE;
IF CHCNT<>0
THEN NEWLINE;
NEWLINE;
SECTION←OUT(TREEPNT,[POWER,ARRAYS,RECORDS,FILES]);
TABS:=FALSE;
END (* TREEPNT<>NIL *)
ELSE
BEGIN
WRITE(TTY,'+++ NO VARIABLES +++');
NEWLINE;NEWLINE;
END;
NEWLINE;NEWLINE;
EXIT IF (MERKBASIS=NULLPTR) OR (CALLCNT=10);
CALLCNT:=CALLCNT+1;
BASIS:=MERKBASIS;
SUCCBASIS(SIDE);
END (* LOOP *);
IF MERKBASIS=NULLPTR
THEN
SECTION←OUT(ENTRY1.STANDARDIDTREE,[FILES]);
END (* OUT *);
(** STACK←OUT HEAP←OUT **)
PROCEDURE STACK←OUT;
BEGIN
NEWLINE;NEWLINE;
WRITELN(TTY,' ':40,'VARIABLES OF THE CALLED PROCEDURE(S)');
WRITE(TTY,'$',' ':41,'====================================');
NEWLINE;NEWLINE;
OUT(LEFT);
IF MERKBASIS<>NULLPTR
THEN
BEGIN
NEWLINE;NEWLINE;
WRITE(TTY,' BECAUSE THERE ARE MORE THAN 10 DYNAMIC NESTED PROCEDURES AND/OR FUNCTIONS');
NEWLINE;
WRITE(TTY,' NOW ONLY THE VARIABLES OF THE STATIC NESTED PROCEDURES AND/OR FUNCTIONS ');
NEWLINE;WRITE(TTY,' WILL BE PRINTED OUT');NEWLINE;
NEWLINE;NEWLINE;NEWLINE;
WRITELN(TTY,' ':40,'VARIABLES OF STATIC NESTED PROCEDURES');
WRITE(TTY,'$',' ':41,'=====================================');
NEWLINE;NEWLINE;NEWLINE;
OUT(RIGHT);
END (*BASIS<>.. *);
END (* ALL←VAR←OUT *);
PROCEDURE HEAP←OUT;
VAR
REC:ACR;
BEGIN
NEWLINE;
WRITELN(TTY,' ':39,'THE CONTENTS OF THE HEAP');
WRITE(TTY,'$ ',' ':39,'========================');
NEWLINE;
TABS:=FALSE;
REC:=ACRPOINT(ACCUS↑[0+15B],RIGHT);
WITH HEAPCV DO
BEGIN
CIVAL:=REC↑[0];
IF (CIDTYPE=NIL) AND (CACR=NIL)
THEN
BEGIN
NEWLINE;
WRITE(TTY,' NO VARIABLES ALLOCATED');
NEWLINE;
END
ELSE
WHILE CACR<>NIL DO
BEGIN
IF (ORD(CACR) > ORD(ACCUS)) OR
(ORD(CACR) <= ACCUS↑[0+15B]) OR
(ORD(CACR) <= ORD(REC)) OR
(ORD(CIDTYPE) < ORD(NIL)) OR
(ORD(CIDTYPE) > ORD(ENTRY2.ENTRYPTR))
THEN
BEGIN
NEWLINE;
WRITE(TTY,' CANT CONTINUE THE HEAP-DUMP');
CACR:=NIL;
NEWLINE;
END
ELSE
BEGIN
NEWLINE;
WRITE(TTY,(ORD(REC)+1):6:O,'B↑=');
CHCNT:=CHCNT+9;
IF CIDTYPE=NIL
THEN
BEGIN
NEWLINE;
WRITE(TTY,' TYPE OF REFERENCED VARIABLE NOT KNOWN');
NEWLINE;
END
ELSE
WITH GATTR DO
BEGIN
NL:=TRUE;
TYPTR:=CIDTYPE;
KIND:=VARBL;
PACKFG:=FALSE;
GADDR:=ORD(REC)+1;
MAXADDR:=ORD(CACR) - 1;
GBITCOUNT:=0;
WRITESTRUCTURE(CIDTYPE);
END (* WITH GATTR *);
TABS:=FALSE;
REC:=CACR;
CIVAL:=REC↑[0];
NEWLINE;
END (* POINTER OK *);
END (* WHILE *);
END (* WITH HEAPCV *);
NEWLINE;
END (* HEAP←OUT *);
(** WRITE←PROGRAM←NAME HEADER BACK←TO←TTY CORRECT←ADDR RIGHT←ADDR **)
PROCEDURE WRITE←PROGRAM←NAME;
BEGIN
WITH POINTERCV DO
BEGIN
ADDR := ORD(ACRPOINT(ENTRY2.NAME←PNT←PNT↑[0],RIGHT));
SHIFTED←OUT(ALFAPNT↑);
END;
WRITELN(TTY)
END (* WRITE←PROGRAM←NAME *);
PROCEDURE HEADER;
BEGIN
LEFTSPACE:=0;
DUMP:=TRUE;
TIME(DAY←TIME);
DATE(DAY);
FILE←NAME:=' PMD';
FILE←NAME[1]:=DAY←TIME[1];
FILE←NAME[2]:=DAY←TIME[2];
FILE←NAME[3]:=DAY←TIME[4];
FILE←NAME[4]:=DAY←TIME[5];
FILE←NAME[5]:=DAY←TIME[7];
FILE←NAME[6]:=DAY←TIME[8];
IF ENTRY2.INTERACTIVE
THEN
DEVICE:='DSK '
ELSE DEVICE:='LPT ';
REWRITE(TTYOUTPUT,FILE←NAME,0,0,DEVICE);
NEWLINE;
WRITE(TTY,DAY:20,DAY←TIME:20,'PROGRAM-NAME ':20);
WRITE←PROGRAM←NAME;
WRITE(TTY,'$ ');
END (* HEADER *);
PROCEDURE BACK←TO←TTY;
BEGIN
TABS:=FALSE;
DUMP := FALSE;
REWRITE(TTYOUTPUT,'123456789',0,0,'TTY ');
IF ENTRY2.INTERACTIVE
THEN WRITE(TTY,'$');
NEWLINE;
NEWLINE;
WRITELN(TTY,'LOOK FOR DUMP ON FILE ',FILE←NAME:6,
'.',FILE←NAME[7],FILE←NAME[8],FILE←NAME[9]);
END (* BACK←TO←TTY *);
PROCEDURE CORRECT←ADDR;
VAR
PAGEPOINTER:↑PAGEELEM;
FUNCTION RIGHT←ADDR:ADDRRANGE;
VAR
HELP:INTEGER;
LACR:ACR;
BEGIN
FIRSTBASIS;
IF BASIS=NULLPTR
THEN RIGHT←ADDR:=ORD(ACRPOINT(ENTRY2.STACKBOTTOM↑[0+2]-1,RIGHT))
ELSE
BEGIN
LACR:=ACRPOINT(BASIS↑[0]-1,RIGHT);
HELP:=LACR↑[0];
REPEAT
HELP:=HELP+1;
LACR:=ACRPOINT(HELP,RIGHT);
UNTIL ORD(ACRPOINT(LACR↑[0],LEFT))=541757B (*HRRI 17,?(17)*);
HELP:=ORD(ACRPOINT(LACR↑[0],RIGHT));
RIGHT←ADDR:=ORD(ACRPOINT(BASIS↑[HELP+1]-1,RIGHT));
END;
END (* RIGHT←ADDR *);
BEGIN
WITH ENTRY1,ENTRY2.STATUS DO
BEGIN
IF ORD(ENTRY2.ENTRYPTR) <= RETURNADDR
THEN
RETURNADDR:=RIGHT←ADDR
ELSE
BEGIN
PAGEPOINTER:=LASTPAGEELEM.PAGPTR;
IF ORD(PAGEPOINTER) <> 0
THEN
WHILE ORD(PAGEPOINTER↑.PAGPTR) <> 0 DO
PAGEPOINTER:=PAGEPOINTER↑.PAGPTR;
IF (ORD(PAGEPOINTER) > RETURNADDR) OR ( ORD(PAGEPOINTER) = 0 )
THEN
RETURNADDR:=RIGHT←ADDR;
END (* ELSE *);
END (* WITH *);
END (* CORRECT←ADDR *);
(** INIT DEBUG←INTERACTIVE **)
PROCEDURE INIT;
BEGIN
WITH POINTERCV DO
BEGIN
ADDR := 140B;
ENTRY2 := ENTPTR2↑
END;
ENTRY1 := ENTRY2.ENTRYPTR↑;
ACCUS := ENTRY2.REGISTRS;
NULLPTR := ACRPOINT(0,RIGHT);
IF ENTRY2.STATUS.KIND IN [DDTK,RUNTMERRK]
THEN CORRECT←ADDR;
LADDR := ENTRY2.STATUS.RETURNADDR;
END (*INIT*);
PROCEDURE DEBUG←INTERACTIVE;
LABEL
1;
VAR
OPEN←TTY: BOOLEAN;
BEGIN
WRITELN(TTY);
BREAK;
OPEN←TTY := TRUE;
CASE ENTRY2.STATUS.KIND OF
INITK:
BEGIN
ID := 'TTY '; VARIABLE; (*FILEBLOCK(TTY)-->GATTR*)
IF BASIS↑[GATTR.GADDR+13B] = 0
THEN
OPEN←TTY := FALSE;
(* TO BE SURE THAT THE TTY-INPUT FILE HAS BEEN OPENED *)
WRITE(TTY, VERSION:5,': ');
WRITE←PROGRAM←NAME;
END;
STOPK:
BEGIN
FOR STOPNR := 1 TO STOPMAX DO
WITH STOPTABLE[STOPNR] DO
IF ORD(THISADDR) = LADDR
THEN
BEGIN
WRITE(TTY,'$ STOP AT ', THISLINE:LENGTH(THISLINE), '/', PAGE:LENGTH(PAGE),' IN ');
WRITE←PROGRAM←NAME;
GOTO 1
END;
STOPMESSAGE(LADDR); (*,IF NOT FOUND*)
1:
END;
DDTK:
BEGIN
WRITE(TTY, '$ STOP BY DDT COMMAND IN ');
WRITE←PROGRAM←NAME;
STOPMESSAGE(LADDR)
END;
HALTK, RUNTMERRK:
BEGIN
IF ENTRY2.STATUS.KIND = RUNTMERRK
THEN
WRITE(TTY,'$ STOP BY RUNTIME ERROR IN ')
ELSE
WRITE(TTY,'$ STOP BY HALT IN ');
WRITE←PROGRAM←NAME;
STOPMESSAGE(LADDR)
END
END (*CASE*);
BUFFLNG := 0;
WHILE NOT EOLN(TTY) AND OPEN←TTY DO
BEGIN
BUFFLNG := BUFFLNG + 1;
(*READ ( TTY, BUFFER[BUFFLNG] )*) BUFFER[BUFFLNG] := TTY↑; GET(TTY)
END;
REPEAT
REPEAT
WRITE(TTY,'$'); BREAK;
IF OPEN←TTY
THEN READLN(TTY)
ELSE
BEGIN
OPEN←TTY := TRUE;
RESET(TTY,'TTY ',0,0,'TTY ');
END;
UNTIL NOT EOLN(TTY);
READ(TTY,CH); CHCNT := 0;
INSYMBOL;
CASE SY OF
STOPSY:
BEGIN
INSYMBOL;
BREAKPOINT
END;
STACKDUMPSY,
HEAPDUMPSY:
BEGIN
HEADER;
WRITELN(TTY);
STOPMESSAGE(LADDR);
WRITE(TTY,'$');
NEWLINE;
TRACEOUT;
WRITE(TTY,'$ ');
IF SY=STACKDUMPSY
THEN STACK←OUT
ELSE HEAP←OUT;
BACK←TO←TTY;
END;
TRACESY:
TRACEOUT;
IDENT, NOTSY, (*EXPRESSION-BEGIN-SYMBOLS*)
INTCONST, REALCONST, CHARCONST, STRINGCONST, PLUS, MINUS,
LPARENT:
BEGIN
EXPRESSION;
CASE SY OF
EQSY:
WITH GATTR DO
IF TYPTR <> NIL
THEN
BEGIN
WRITE(TTY,'$ ');
CHCNT := 0; LEFTSPACE := 0; NL := FALSE;
IF KIND <> VARBL
THEN
IF TYPTR↑.FORM = ARRAYS
THEN
BEGIN
GADDR := CVAL.IVAL;
BASIS := NULLPTR;
WRITESTRUCTURE ( TYPTR )
END
ELSE WRITESCALAR(CVAL.IVAL,TYPTR)
ELSE WRITESTRUCTURE( TYPTR );
WRITELN(TTY)
END;
BECOMES:
BEGIN
INSYMBOL; ASSIGNMENT
END;
OTHERS:
BEGIN
ERROR; WRITELN(TTY, '"=" OR ":=" EXPECTED')
END
END (*CASE*)
END;
ENDSY, EOLSY: (*EMPTY*) ;
OTHERS:
WRITELN(TTY,'$ COMMAND ERROR')
END (*CASE*)
UNTIL SY=ENDSY;
IF ENTRY2.STATUS.KIND IN [RUNTMERRK,HALTK]
THEN WRITELN(TTY,'$ CANNOT CONTINUE')
ELSE
BEGIN
WHILE SY <> EOLSY DO INSYMBOL;
IF (BUFFLNG > 0) AND (ENTRY2.STATUS.KIND <> DDTK)
THEN WITH GATTR DO
BEGIN
ID := 'TTY '; VARIABLE; (*FILEBLOCK(TTY)-->GATTR*)
BASIS↑[GADDR+25B(*FILCMP*)] := ORD(BUFFER[1]);
BASIS↑[GADDR+ 2B(*FILEOL*)] := ORD(FALSE);
BASIS↑[GADDR+22B(*FILBTC*)] := BUFFLNG + 2;
LADDR := BASIS↑[GADDR+20B(*FILBFH*)]+2; (*ADDR OF 1ST DATA*)
BASIS↑[GADDR+21B(*FILBTP*)] := 010700000000B + LADDR -1;
GADDR := LADDR; PACKFG:= TRUE;
FOR CHCNT := 2 TO BUFFLNG DO PUTNEXTBYTE(7,ORD(BUFFER[CHCNT]));
PUTNEXTBYTE(7,015B); PUTNEXTBYTE(7,012B); (*<CR><LF>*)
FOR CHCNT := 1 TO 4 DO PUTNEXTBYTE(7,0); (*CLEAR WITH NULL*)
WRITELN(TTY,'$ INPUT RESCANNED(!) : ', BUFFER:BUFFLNG);
BREAK
END;
WRITELN(TTY)
END
END (*DEBUG←INTERACTIVE*);
(** DEBUG←BATCH **)
PROCEDURE DEBUG←BATCH;
BEGIN
CASE ENTRY2.STATUS.KIND OF
INITK:
WITH POINTERCV DO
BEGIN
WRITE(TTY,VERSION:5,': ');
WRITE←PROGRAM←NAME;
ADDR:=140B;
ENTPTR2↑.TIME←LIMIT:= 4 * ((ENTRY2.TIME←LIMIT + CLOCK) DIV 5);
BREAK;
END;
HALTK, RUNTMERRK:
BEGIN
HEADER;
NEWLINE;
NEWLINE;
WRITELN(TTY,'***************************************************':90);
WRITELN(TTY,'$','*':41,'*':50);
WRITELN(TTY,'$','*':41,'*':50);
WRITELN(TTY,'$','*':41,' P O S T - M O R T E M - D U M P *':51);
WRITELN(TTY,'$','*':41,VERSION:34,'*':16);
WRITELN(TTY,'$','*':41,'*':50);
WRITELN(TTY,'$','***************************************************':91);
WRITE(TTY,'$');
NEWLINE;
WRITELN(TTY);
STOPMESSAGE(LADDR);
WRITE(TTY,'$ ');
IF ENTRY2.STATUS.KIND = HALTK
THEN WRITE(TTY,'STOP BY HALT')
ELSE WRITE(TTY,'STOP BY RUNTIME ERROR');
NEWLINE;
NEWLINE;
TRACEOUT;
WRITE(TTY,'$');
STACK←OUT;
NEWLINE;
HEAP←OUT;
WRITE(TTY,' END OF POST - MORTEM - DUMP');
BACK←TO←TTY;
END;
OTHERS:
WRITELN(TTY,'$ POST-MORTEM-DUMP ERROR')
END;
END;
(*!!!!!!!!!!!!!!!!!!!!!! DEBUG !!!!!!!!!!!!!!!!!!!!!!!!*)
BEGIN
INIT;
IF ENTRY2.INTERACTIVE
THEN
DEBUG←INTERACTIVE
ELSE
DEBUG←BATCH;
END;
BEGIN
END.
PROGRAM STATUS, GETSTATUS;
(*******************************************************************************
*
* PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
*
* PROCEDURE GETSTATUS
*
* - ASSIGN APPROPRIATE VALUES TO
* "FILENAME", "PROTECTION", "UFD" AND "DEVICE"
* AS FOUND IN "FILE←BLOCK".
*
* GETSTATUS IS A PRE-DECLARED PROCEDURE AND AVAILABLE TO
* EVERY PASCAL USER.
*
******************************************************************************)
TYPE
LEFTORRIGHT = (LEFT,RIGHT);
ASCII = PACKED ARRAY[1..5] OF CHAR;
PACK6 = PACKED ARRAY[1..6] OF CHAR;
PACK9 = PACKED ARRAY[1..9] OF CHAR;
THREEBIT = PACKED ARRAY[1..12] OF 0..7;
HALFWORD = PACKED ARRAY[LEFTORRIGHT] OF 0..777777B;
SIXBIT = PACKED ARRAY[1..6] OF 0..77B;
FILEBLOCKPOINTER = ↑FILEBLOCK;
FILEBLOCK = RECORD
FILEOF,FILPTR:INTEGER;
FILEOL:BOOLEAN;
FILSTA,FILCLS,FILOUT,FILIN,FILENT,
FILLKP,FILOPN:INTEGER;
FILDEV:SIXBIT;
FILPBH:HALFWORD;
FILEXT,FILNAM:SIXBIT;
FILPROT:THREEBIT;
FILPPN: INTEGER;
FILBTC,FILBTP,FILBFH:INTEGER;
FILLNR:ASCII;
FILCMP,FILCNT:INTEGER
END;
(** GETSTATUS **)
PROCEDURE GETSTATUS(FILE←BLOCK: FILEBLOCKPOINTER;
VAR FILENAME: PACK9;
VAR PROTECTION, UFD: INTEGER;
VAR DEVICE: PACK6);
VAR
I: INTEGER;
BEGIN
(*GETSTATUS*)
WITH FILE←BLOCK↑ DO
BEGIN
UFD := FILPPN;
PROTECTION := 0;
FOR I := 1 TO 3 DO PROTECTION := PROTECTION*10B + FILPROT[I];
FOR I := 1 TO 6 DO FILENAME[I] := CHR(FILNAM[I] + 40B);
FOR I := 1 TO 3 DO FILENAME[I+6] := CHR(FILEXT[I] + 40B);
FOR I := 1 TO 6 DO DEVICE[I] := CHR(FILDEV[I] + 40B)
END
END (*GETSTATUS*);
BEGIN
END.
PROGRAM READ, READSCALAR, READIRANGE,
READCRANGE, READRRANGE, READISET, READCSET, READDSET;
(************************************************************************************
*
* PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
*
* EXTENDED FORMATTED INPUT
*
* - READSCALAR : READ IDENTIFIERS OF DECLARED SCALARS
*
* - READIRANGE,
* READCRANGE,
* READRRANGE : READ SUBRANGE OF INTEGER, CHAR OR REAL
* WITH BOUNDARY CHECKS
*
* - READISET,
* READCSET,
* READDSET : READ SETS OF INTEGER, CHAR OR DECLARED SCALARS
* OR THEIR SUBRANGES WITH BOUNDARY CHECKS
*
************************************************************************************)
CONST
MAXSET = 71;
OFFSET = 40B;
TYPE
SETRANGE = 0..MAXSET;
VECTOR = ↑NAME←VECTOR;
NAME←VECTOR = ARRAY[0..0] OF ALFA;
STANDARD←SET = SET OF SETRANGE;
SCALAR←FORM = (INTEGER←FORM,CHAR←FORM,REAL←FORM,BOOL←FORM,DECLARED←FORM);
VAR
ERRORMESSAGE: PACKED ARRAY[1..4,1..45] OF CHAR;
CH: CHAR; DIRECT←CALL, ERROR←EXIT: BOOLEAN;
IDENTIFIER: ALFA;
INITPROCEDURE;
BEGIN
ERRORMESSAGE[1] := 'INPUT ERROR: INVALID SCALAR SPECIFICATION ';
ERRORMESSAGE[2] := 'INPUT ERROR: SCALAR UNDEFINED OR OUT OF RANGE';
ERRORMESSAGE[3] := 'INPUT ERROR; INVALID SET SPECIFICATION ';
ERRORMESSAGE[4] := 'INPUT ERROR: SET ELEMENT SPECIFIED DOUBLE ';
DIRECT←CALL := TRUE; ERROR←EXIT := FALSE;
END;
(** STOP ERROR NEXTCH SKIP READIRANGE READCRANGE READRRANGE **)
PROCEDURE STOP; EXTERN;
PROCEDURE ERROR( ERRORNUMBER: INTEGER);
BEGIN
IF NOT ERROR←EXIT
THEN
BEGIN
WRITELN(TTY);
WRITE(TTY,'%? ',ERRORMESSAGE[ERRORNUMBER]);
BREAK(TTY);
ERROR←EXIT := TRUE
END
END;
PROCEDURE NEXTCH( VAR SOURCE←FILE: TEXT);
BEGIN
IF NOT EOLN(SOURCE←FILE)
THEN READ(SOURCE←FILE,CH)
ELSE CH := ' '
END;
PROCEDURE SKIP( VAR SOURCE←FILE: TEXT);
BEGIN
IF EOLN(SOURCE←FILE)
THEN READLN(SOURCE←FILE);
NEXTCH(SOURCE←FILE);
WHILE (CH = ' ') AND NOT (EOF(SOURCE←FILE) OR EOLN(SOURCE←FILE)) DO
NEXTCH(SOURCE←FILE)
END;
PROCEDURE READIRANGE( VAR SOURCE←FILE: TEXT;
VAR SCALAR←VARIABLE: INTEGER;
MIN←VALUE, MAX←VALUE: INTEGER);
VAR
NEGATIVE: BOOLEAN;
BEGIN
IF DIRECT←CALL
THEN SKIP(SOURCE←FILE);
NEGATIVE := FALSE; SCALAR←VARIABLE := 0;
IF CH IN ['+','-']
THEN
BEGIN
NEGATIVE := CH = '-';
NEXTCH(SOURCE←FILE)
END;
IF NOT (CH IN ['0'..'9'])
THEN ERROR(1);
WHILE CH IN ['0'..'9'] DO
BEGIN
SCALAR←VARIABLE := SCALAR←VARIABLE * 10 + (ORD(CH) - ORD('0'));
NEXTCH(SOURCE←FILE)
END;
IF (SCALAR←VARIABLE < MIN←VALUE) OR (SCALAR←VARIABLE > MAX←VALUE)
THEN
BEGIN
ERROR(2); WRITE(TTY,' ***',SCALAR←VARIABLE,'***')
END;
IF DIRECT←CALL AND ERROR←EXIT
THEN
BEGIN
ERROR←EXIT := FALSE;
BREAK(TTY);
STOP
END
ELSE DIRECT←CALL := TRUE
END;
PROCEDURE READCRANGE( VAR SOURCE←FILE: TEXT;
VAR SCALAR←VARIABLE: CHAR;
MIN←VALUE, MAX←VALUE: CHAR);
BEGIN
IF EOLN(SOURCE←FILE)
THEN READLN(SOURCE←FILE);
READ(SOURCE←FILE,CH);
SCALAR←VARIABLE := CH;
IF (SCALAR←VARIABLE < MIN←VALUE) OR (SCALAR←VARIABLE > MAX←VALUE)
THEN
BEGIN
ERROR(2); WRITE(TTY,' ***''',SCALAR←VARIABLE,'''***')
END;
IF DIRECT←CALL AND ERROR←EXIT
THEN
BEGIN
ERROR←EXIT := FALSE;
BREAK(TTY);
STOP
END
ELSE DIRECT←CALL := TRUE
END;
PROCEDURE READRRANGE( VAR SOURCE←FILE: TEXT;
VAR SCALAR←VARIABLE: REAL;
MIN←VALUE, MAX←VALUE: REAL);
BEGIN
IF EOLN(SOURCE←FILE)
THEN READLN(SOURCE←FILE);
READ(SOURCE←FILE,SCALAR←VARIABLE);
IF (SCALAR←VARIABLE < MIN←VALUE) OR (SCALAR←VARIABLE > MAX←VALUE)
THEN
BEGIN
ERROR(2); WRITE(TTY,' ***',SCALAR←VARIABLE,'***')
END;
IF DIRECT←CALL AND ERROR←EXIT
THEN
BEGIN
ERROR←EXIT := FALSE;
BREAK(TTY);
STOP
END
ELSE DIRECT←CALL := TRUE
END;
(** READSCALAR READIDENTIFIER READSET **)
PROCEDURE READSCALAR( VAR SOURCE←FILE: TEXT;
VAR SCALAR←VARIABLE: INTEGER;
MIN←VALUE, MAX←VALUE: INTEGER;
SCALAR←NAME: VECTOR);
PROCEDURE READIDENTIFIER;
VAR
I: INTEGER;
BEGIN
IDENTIFIER := ' '; I := 1;
IF NOT (CH IN ['A'..'Z'])
THEN ERROR(1)
ELSE
LOOP
IDENTIFIER[I] := CH;
NEXTCH(SOURCE←FILE)
EXIT IF NOT (CH IN ['0'..'9','A'..'Z','←']);
IF I < ALFALENGTH
THEN I := I + 1
END
END;
BEGIN (*READSCALAR*)
IF DIRECT←CALL
THEN SKIP(SOURCE←FILE);
READIDENTIFIER; SCALAR←VARIABLE := MIN←VALUE;
WHILE (SCALAR←NAME↑[-SCALAR←VARIABLE] <> IDENTIFIER) AND NOT ERROR←EXIT DO
IF SCALAR←VARIABLE < MAX←VALUE
THEN SCALAR←VARIABLE := SCALAR←VARIABLE+1
ELSE
BEGIN
ERROR(2); WRITE(TTY,' ***',IDENTIFIER,'***')
END;
IF DIRECT←CALL AND ERROR←EXIT
THEN
BEGIN
ERROR←EXIT := FALSE;
BREAK(TTY);
STOP
END
ELSE DIRECT←CALL := TRUE
END;
PROCEDURE READSET( VAR SOURCE←FILE: TEXT;
VAR SET←VARIABLE: STANDARD←SET;
MIN←VALUE, MAX←VALUE: INTEGER;
SCALAR←NAME: VECTOR;
ELEMENT←FORM: SCALAR←FORM);
LABEL
111;
VAR
SCALAR←VALUE: RECORD
CASE SCALAR←FORM OF
INTEGER←FORM: (IVAL: INTEGER);
CHAR←FORM : (CVAL: CHAR)
END;
I, FIRST←SCALAR: INTEGER;
SUBRANGE: BOOLEAN;
BEGIN
SUBRANGE := FALSE;
FIRST←SCALAR := 0;
SET←VARIABLE := [];
SKIP(SOURCE←FILE);
IF MAX←VALUE = 0
THEN MAX←VALUE := MAXSET;
IF NOT EOF(SOURCE←FILE)
THEN
BEGIN
IF CH = '['
THEN
BEGIN
SKIP(SOURCE←FILE);
IF CH <> ']'
THEN
LOOP
DIRECT←CALL := FALSE;
CASE ELEMENT←FORM OF
INTEGER←FORM:
READIRANGE(SOURCE←FILE,SCALAR←VALUE.IVAL,MIN←VALUE,MAX←VALUE);
CHAR←FORM:
BEGIN
IF CH <> ''''
THEN ERROR(3)
ELSE
BEGIN
READCRANGE(SOURCE←FILE,SCALAR←VALUE.CVAL,CHR(MIN←VALUE),CHR(MAX←VALUE));
IF SCALAR←VALUE.IVAL = ORD('''')
THEN
BEGIN
NEXTCH(SOURCE←FILE) ;
IF CH <> '''' THEN ERROR(3) ;
END ;
SCALAR←VALUE.IVAL := SCALAR←VALUE.IVAL-OFFSET;
NEXTCH(SOURCE←FILE);
IF CH <> ''''
THEN ERROR(3)
ELSE NEXTCH(SOURCE←FILE)
END
END;
DECLARED←FORM:
READSCALAR(SOURCE←FILE,SCALAR←VALUE.IVAL,MIN←VALUE,MAX←VALUE,SCALAR←NAME)
END;
IF SCALAR←VALUE.IVAL IN SET←VARIABLE
THEN
BEGIN
IF NOT ERROR←EXIT
THEN
BEGIN
ERROR(4); WRITE(TTY,' ***');
CASE ELEMENT←FORM OF
INTEGER←FORM:
WRITE(TTY,SCALAR←VALUE.IVAL);
CHAR←FORM:
BEGIN
IF SCALAR←VALUE.IVAL + OFFSET = ORD('''')
THEN WRITE(TTY,'''') ;
WRITE(TTY,'''',CHR(SCALAR←VALUE.IVAL+OFFSET),'''');
END ;
DECLARED←FORM:
WRITE(TTY,IDENTIFIER)
END;
WRITE(TTY,'***')
END
END
ELSE
IF SUBRANGE
THEN
FOR I := FIRST←SCALAR+1 TO SCALAR←VALUE.IVAL DO
SET←VARIABLE := SET←VARIABLE + [ I ]
ELSE
SET←VARIABLE := SET←VARIABLE + [ SCALAR←VALUE.IVAL ];
SUBRANGE := FALSE;
IF (CH = ' ') AND NOT ERROR←EXIT
THEN SKIP(SOURCE←FILE)
EXIT IF NOT (CH IN [',','.',':']) OR ERROR←EXIT;
IF CH IN ['.',':']
THEN
BEGIN
SUBRANGE := TRUE;
FIRST←SCALAR := SCALAR←VALUE.IVAL
END;
IF CH = '.'
THEN
BEGIN
NEXTCH(SOURCE←FILE);
IF CH <> '.'
THEN
BEGIN
ERROR(3); GOTO 111
END
END;
SKIP(SOURCE←FILE)
END;
111:
DIRECT←CALL := TRUE;
IF (CH <> ']')
THEN ERROR(3)
END
ELSE ERROR(3)
END
ELSE ERROR(3)
END;
(** READISET READCSET READDSET **)
PROCEDURE READISET( VAR SOURCE←FILE: TEXT;
VAR SET←VARIABLE: STANDARD←SET;
MIN←VALUE, MAX←VALUE: INTEGER);
BEGIN
READSET(SOURCE←FILE,SET←VARIABLE,MIN←VALUE,MAX←VALUE,NIL,INTEGER←FORM);
IF ERROR←EXIT
THEN
BEGIN
ERROR←EXIT := FALSE;
BREAK(TTY);
STOP
END
END;
PROCEDURE READCSET( VAR SOURCE←FILE: TEXT;
VAR SET←VARIABLE: STANDARD←SET;
MIN←VALUE, MAX←VALUE: INTEGER);
BEGIN
READSET(SOURCE←FILE,SET←VARIABLE,MIN←VALUE,MAX←VALUE,NIL,CHAR←FORM);
IF ERROR←EXIT
THEN
BEGIN
ERROR←EXIT := FALSE;
BREAK(TTY);
STOP
END
END;
PROCEDURE READDSET( VAR SOURCE←FILE: TEXT;
VAR SET←VARIABLE: STANDARD←SET;
MIN←VALUE, MAX←VALUE: INTEGER;
SCALAR←NAME: VECTOR);
BEGIN
READSET(SOURCE←FILE,SET←VARIABLE,MIN←VALUE,MAX←VALUE,SCALAR←NAME,DECLARED←FORM);
IF ERROR←EXIT
THEN
BEGIN
ERROR←EXIT := FALSE;
BREAK(TTY);
STOP
END
END;
BEGIN
END.
PROGRAM WRITE, WRTSCALAR, WRTISET, WRTCSET, WRTDSET;
(************************************************************************************
*
* PASCAL RUNTIME SYSTEM (29-JUL-76,KISICKI)
*
* EXTENDED FORMATTED OUTPUT
*
* - WRTSCALAR : WRITE IDENTIFIERS OF DECLARED SCALARS
*
* - WRTISET,
* WRTCSET,
* WRTDSET : WRITE SETS OF INTEGER, CHAR OR DECLARED SCALARS
* OR THEIR SUBRANGES
*
************************************************************************************)
CONST
MAXSET = 71;
OFFSET = 40B;
HALFWORD = 777777B;
INTSTDLGTH = 12;
TYPE
HALFRANGE = 0..HALFWORD;
SETRANGE = 0..MAXSET;
VECTOR = ↑NAME←VECTOR;
NAME←VECTOR = ARRAY[0..0] OF ALFA;
STANDARD←SET = SET OF SETRANGE;
SCALAR←FORM = (INTEGER←FORM,CHAR←FORM,REAL←FORM,BOOL←FORM,DECLARED←FORM);
PAIR = PACKED RECORD
VALUE: HALFRANGE;
LENGTH: HALFRANGE
END;
VAR
DIRECT←CALL: BOOLEAN;
INITPROCEDURE;
BEGIN
DIRECT←CALL := TRUE
END;
(** WRTSCALAR WRTSET WRTISET WRTCSET WRTDSET **)
PROCEDURE WRTSCALAR( VAR TARGET←FILE: TEXT;
SCALAR←VALUE: INTEGER;
MAXIMUM: PAIR;
SCALAR←NAME: VECTOR);
VAR
I: INTEGER;
BEGIN
IF (SCALAR←VALUE >= 0) AND (SCALAR←VALUE <= MAXIMUM.VALUE)
THEN
WITH MAXIMUM DO
BEGIN
IF LENGTH=0 THEN LENGTH:=10 (*DEFAULT FORMAT*);
I := 0;
WHILE SCALAR←NAME↑[-SCALAR←VALUE,I+1] <> ' ' DO I := I + 1;
IF LENGTH < I THEN WRITE(TARGET←FILE,SCALAR←NAME↑[-SCALAR←VALUE]:LENGTH) ELSE BEGIN
WRITE(TARGET←FILE,' ':(LENGTH-I));
WRITE(TARGET←FILE,SCALAR←NAME↑[-SCALAR←VALUE]:I)
END
END
ELSE
WRITE(TARGET←FILE,'**********');
DIRECT←CALL := TRUE
END;
PROCEDURE WRTSET( VAR TARGET←FILE: TEXT;
SET←VALUE: STANDARD←SET;
MAXIMUM: PAIR;
SCALAR←NAME: VECTOR;
ELEMENT←FORM: SCALAR←FORM);
VAR
ELEMENT: SETRANGE;
FIRST←ELEMENT, SUBRANGE: BOOLEAN;
BEGIN
WRITE(TARGET←FILE,'[');
FIRST←ELEMENT := TRUE;
SUBRANGE := FALSE;
ELEMENT := 0;
WHILE ELEMENT <= MAXSET DO
BEGIN
IF ELEMENT IN SET←VALUE
THEN
BEGIN
IF NOT (FIRST←ELEMENT OR SUBRANGE)
THEN WRITE(TARGET←FILE,',');
FIRST←ELEMENT := FALSE;
SUBRANGE := FALSE;
DIRECT←CALL := FALSE;
WITH MAXIMUM DO
CASE ELEMENT←FORM OF
INTEGER←FORM:
BEGIN
IF LENGTH <= 0
THEN LENGTH := INTSTDLGTH;
WRITE(TARGET←FILE,ELEMENT:LENGTH)
END;
CHAR←FORM:
BEGIN
IF LENGTH > 3
THEN
IF (ELEMENT + OFFSET) = ORD('''')
THEN WRITE(TARGET←FILE,' ':(LENGTH-4),'''')
ELSE WRITE(TARGET←FILE,' ':(LENGTH-3));
WRITE(TARGET←FILE,'''',CHR(ELEMENT+OFFSET),'''')
END;
DECLARED←FORM:
WRTSCALAR(TARGET←FILE,ELEMENT,MAXIMUM,SCALAR←NAME)
END;
IF (ELEMENT+1 IN SET←VALUE) AND (ELEMENT+2 IN SET←VALUE)
THEN
BEGIN
WHILE ELEMENT+2 IN SET←VALUE DO
ELEMENT := ELEMENT + 1;
SUBRANGE := TRUE;
WRITE(TARGET←FILE,'..')
END
END;
ELEMENT := ELEMENT + 1
END;
WRITE(TARGET←FILE,']');
DIRECT←CALL := TRUE
END;
PROCEDURE WRTISET( VAR TARGET←FILE: TEXT;
SET←VALUE: STANDARD←SET;
MAXIMUM: PAIR);
BEGIN
WRTSET(TARGET←FILE,SET←VALUE,MAXIMUM,NIL,INTEGER←FORM)
END;
PROCEDURE WRTCSET( VAR TARGET←FILE: TEXT;
SET←VALUE: STANDARD←SET;
MAXIMUM: PAIR);
BEGIN
WRTSET(TARGET←FILE,SET←VALUE,MAXIMUM,NIL,CHAR←FORM)
END;
PROCEDURE WRTDSET( VAR TARGET←FILE: TEXT;
SET←VALUE: STANDARD←SET;
MAXIMUM: PAIR;
SCALAR←NAME: VECTOR);
BEGIN
WRTSET(TARGET←FILE,SET←VALUE,MAXIMUM,SCALAR←NAME,DECLARED←FORM)
END;
BEGIN
END.